September Morn Update

Task/Bitwise-operations/ABAP/bitwise-operations.abap

@@ -0,0 +1,265 @@
+report z_bitwise_operations.
+
+class hex_converter definition.
+  public section.
+    class-methods:
+      to_binary
+        importing
+          hex_value           type x
+        returning
+          value(binary_value) type string,
+
+      to_decimal
+        importing
+          hex_value            type x
+        returning
+          value(decimal_value) type int4.
+endclass.
+
+
+class hex_converter implementation.
+  method to_binary.
+    data(number_of_bits) = xstrlen( hex_value ) * 8.
+
+    do number_of_bits times.
+      get bit sy-index of hex_value into data(bit).
+
+      binary_value = |{ binary_value }{ bit }|.
+    enddo.
+  endmethod.
+
+
+  method to_decimal.
+    decimal_value = hex_value.
+  endmethod.
+endclass.
+
+
+class missing_bitwise_operations definition.
+  public section.
+    class-methods:
+      arithmetic_shift_left
+        importing
+          old_value   type x
+          change_with type x
+        exporting
+          new_value   type x,
+
+      arithmetic_shift_right
+        importing
+          old_value   type x
+          change_with type x
+        exporting
+          new_value   type x,
+
+      logical_shift_left
+        importing
+          old_value   type x
+          change_with type x
+        exporting
+          new_value   type x,
+
+      logical_shift_right
+        importing
+          old_value   type x
+          change_with type x
+        exporting
+          new_value   type x,
+
+      rotate_left
+        importing
+          old_value   type x
+          change_with type x
+        exporting
+          new_value   type x,
+
+      rotate_right
+        importing
+          old_value   type x
+          change_with type x
+        exporting
+          new_value   type x.
+endclass.
+
+
+class missing_bitwise_operations implementation.
+  method arithmetic_shift_left.
+    clear new_value.
+
+    new_value = old_value * 2 ** change_with.
+  endmethod.
+
+
+  method arithmetic_shift_right.
+    clear new_value.
+
+    new_value = old_value div 2 ** change_with.
+  endmethod.
+
+
+  method logical_shift_left.
+    clear new_value.
+
+    data(bits) = hex_converter=>to_binary( old_value ).
+
+    data(length_of_bit_sequence) = strlen( bits ).
+
+    bits = shift_left(
+      val = bits
+      places = change_with ).
+
+    while strlen( bits ) < length_of_bit_sequence.
+      bits = |{ bits }0|.
+    endwhile.
+
+    do strlen( bits ) times.
+      data(index) = sy-index - 1.
+
+      data(current_bit) = bits+index(1).
+
+      if current_bit eq `1`.
+        set bit sy-index of new_value.
+      endif.
+    enddo.
+  endmethod.
+
+
+  method logical_shift_right.
+    clear new_value.
+
+    data(bits) = hex_converter=>to_binary( old_value ).
+
+    data(length_of_bit_sequence) = strlen( bits ).
+
+    bits = shift_right(
+      val = bits
+      places = change_with ).
+
+    while strlen( bits ) < length_of_bit_sequence.
+      bits = |0{ bits }|.
+    endwhile.
+
+    do strlen( bits ) times.
+      data(index) = sy-index - 1.
+
+      data(current_bit) = bits+index(1).
+
+      if current_bit eq `1`.
+        set bit sy-index of new_value.
+      endif.
+    enddo.
+  endmethod.
+
+
+  method rotate_left.
+    clear new_value.
+
+    data(bits) = hex_converter=>to_binary( old_value ).
+
+    bits = shift_left(
+      val = bits
+      circular = change_with ).
+
+    do strlen( bits ) times.
+      data(index) = sy-index - 1.
+
+      data(current_bit) = bits+index(1).
+
+      if current_bit eq `1`.
+        set bit sy-index of new_value.
+      endif.
+    enddo.
+  endmethod.
+
+
+  method rotate_right.
+    clear new_value.
+
+    data(bits) = hex_converter=>to_binary( old_value ).
+
+    bits = shift_right(
+      val = bits
+      circular = change_with ).
+
+    do strlen( bits ) times.
+      data(index) = sy-index - 1.
+
+      data(current_bit) = bits+index(1).
+
+      if current_bit eq `1`.
+        set bit sy-index of new_value.
+      endif.
+    enddo.
+  endmethod.
+endclass.
+
+
+start-of-selection.
+  data:
+    a      type x length 4 value 255,
+    b      type x length 4 value 2,
+    result type x length 4.
+
+  write: |a         -> { a }, { hex_converter=>to_binary( a ) }, { hex_converter=>to_decimal( a ) }|, /.
+
+  write: |b         -> { b }, { hex_converter=>to_binary( b ) }, { hex_converter=>to_decimal( b ) }|, /.
+
+  result = a bit-and b.
+  write: |a & b     -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  result = a bit-or b.
+  write: |a \| b     -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  result = a bit-xor b.
+  write: |a ^ b     -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  result = bit-not a.
+  write: |~a        -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  missing_bitwise_operations=>arithmetic_shift_left(
+    exporting
+      old_value = bit-not a
+      change_with = b
+    importing
+      new_value = result ).
+  write: |~a << b   -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  missing_bitwise_operations=>arithmetic_shift_right(
+    exporting
+      old_value = bit-not a
+      change_with = b
+    importing
+      new_value = result ).
+  write: |~a >> b   -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  missing_bitwise_operations=>logical_shift_left(
+    exporting
+      old_value = a
+      change_with = b
+    importing
+      new_value = result ).
+  write: |a <<< b   -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  missing_bitwise_operations=>logical_shift_right(
+    exporting
+      old_value = bit-not a
+      change_with = b
+    importing
+      new_value = result ).
+  write: |~a >>> b  -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  missing_bitwise_operations=>rotate_left(
+    exporting
+      old_value = bit-not a
+      change_with = b
+    importing
+      new_value = result ).
+  write: |~a rotl b -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.
+
+  missing_bitwise_operations=>rotate_right(
+    exporting
+      old_value = a
+      change_with = b
+    importing
+      new_value = result ).
+  write: |a rotr b  -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

Task/Bitwise-operations/AppleScript/bitwise-operations-1.applescript

@@ -0,0 +1,355 @@
+use AppleScript version "2.4"
+use framework "Foundation"
+use scripting additions
+
+-- BIT OPERATIONS FOR APPLESCRIPT (VIA JAVASCRIPT FOR AUTOMATION)
+
+-- bitAND :: Int -> Int -> Int
+on bitAND(x, y)
+    jsOp2("&", x, y)
+end bitAND
+
+-- bitOR :: Int -> Int -> Int
+on bitOR(x, y)
+    jsOp2("|", x, y)
+end bitOR
+
+-- bitXOr :: Int -> Int -> Int
+on bitXOR(x, y)
+    jsOp2("^", x, y)
+end bitXOR
+
+-- bitNOT :: Int -> Int
+on bitNOT(x)
+    jsOp1("~", x)
+end bitNOT
+
+-- (<<) :: Int -> Int -> Int
+on |<<|(x, y)
+    if 31 < y then
+        0
+    else
+        jsOp2("<<", x, y)
+    end if
+end |<<|
+
+-- Logical right shift
+-- (>>>) :: Int -> Int -> Int
+on |>>>|(x, y)
+    jsOp2(">>>", x, y)
+end |>>>|
+
+-- Arithmetic right shift
+-- (>>) :: Int -> Int -> Int
+on |>>|(x, y)
+    jsOp2(">>", x, y)
+end |>>|
+
+
+-- TEST ----------------------------------------------------------
+on run
+    -- Using an ObjC interface to Javascript for Automation
+
+    set strClip to bitWise(255, 170)
+    set the clipboard to strClip
+    strClip
+end run
+
+-- bitWise :: Int -> Int -> String
+on bitWise(a, b)
+    set labels to {"a AND b", "a OR b", "a XOR b", "NOT a", ¬
+        "a << b", "a >>> b", "a >> b"}
+    set xs to {bitAND(a, b), bitOR(a, b), bitXOR(a, b), bitNOT(a), ¬
+        |<<|(a, b), |>>>|(a, b), |>>|(a, b)}
+
+    script asBin
+        property arrow : " -> "
+        on |λ|(x, y)
+            justifyRight(8, space, x) & arrow & ¬
+                justifyRight(14, space, y as text) & arrow & showBinary(y)
+        end |λ|
+    end script
+
+    unlines({"32 bit signed integers   (in two's complement binary encoding)", "", ¬
+        unlines(zipWith(asBin, ¬
+            {"a = " & a as text, "b = " & b as text}, {a, b})), "", ¬
+        unlines(zipWith(asBin, labels, xs))})
+end bitWise
+
+-- CONVERSIONS AND DISPLAY
+
+-- bitsFromInt :: Int -> Either String [Bool]
+on bitsFromIntLR(x)
+    script go
+        on |λ|(n, d, bools)
+            set xs to {0 ≠ d} & bools
+            if n > 0 then
+                |λ|(n div 2, n mod 2, xs)
+            else
+                xs
+            end if
+        end |λ|
+    end script
+
+    set a to abs(x)
+    if (2.147483647E+9) < a then
+        |Left|("Integer overflow – maximum is (2 ^ 31) - 1")
+    else
+        set bs to go's |λ|(a div 2, a mod 2, {})
+        if 0 > x then
+            |Right|(replicate(32 - (length of bs), true) & ¬
+                binSucc(map(my |not|, bs)))
+        else
+            set bs to go's |λ|(a div 2, a mod 2, {})
+            |Right|(replicate(32 - (length of bs), false) & bs)
+        end if
+    end if
+end bitsFromIntLR
+
+-- Successor function (+1) for unsigned binary integer
+
+-- binSucc :: [Bool] -> [Bool]
+on binSucc(bs)
+    script succ
+        on |λ|(a, x)
+            if a then
+                if x then
+                    Tuple(a, false)
+                else
+                    Tuple(x, true)
+                end if
+            else
+                Tuple(a, x)
+            end if
+        end |λ|
+    end script
+
+    set tpl to mapAccumR(succ, true, bs)
+    if |1| of tpl then
+        {true} & |2| of tpl
+    else
+        |2| of tpl
+    end if
+end binSucc
+
+-- showBinary :: Int -> String
+on showBinary(x)
+    script showBin
+        on |λ|(xs)
+            script bChar
+                on |λ|(b)
+                    if b then
+                        "1"
+                    else
+                        "0"
+                    end if
+                end |λ|
+            end script
+
+            map(bChar, xs)
+        end |λ|
+    end script
+    bindLR(my bitsFromIntLR(x), showBin)
+end showBinary
+
+
+-- JXA ------------------------------------------------------------------
+
+--jsOp2 :: String -> a -> b -> c
+on jsOp2(strOp, a, b)
+    bindLR(evalJSLR(unwords({a as text, strOp, b as text})), my |id|) as integer
+end jsOp2
+
+--jsOp2 :: String -> a -> b
+on jsOp1(strOp, a)
+    bindLR(evalJSLR(unwords({strOp, a as text})), my |id|) as integer
+end jsOp1
+
+-- evalJSLR :: String -> Either String a
+on evalJSLR(strJS)
+    try -- NB if gJSC is global it must be released
+        -- (e.g. set to null) at end of script
+        gJSC's evaluateScript
+    on error
+        set gJSC to current application's JSContext's new()
+        log ("new JSC")
+    end try
+    set v to unwrap((gJSC's evaluateScript:(strJS))'s toObject())
+    if v is missing value then
+        |Left|("JS evaluation error")
+    else
+        |Right|(v)
+    end if
+end evalJSLR
+
+-- GENERIC FUNCTIONS --------------------------------------------------
+
+-- Left :: a -> Either a b
+on |Left|(x)
+    {type:"Either", |Left|:x, |Right|:missing value}
+end |Left|
+
+-- Right :: b -> Either a b
+on |Right|(x)
+    {type:"Either", |Left|:missing value, |Right|:x}
+end |Right|
+
+-- Tuple (,) :: a -> b -> (a, b)
+on Tuple(a, b)
+    {type:"Tuple", |1|:a, |2|:b, length:2}
+end Tuple
+
+-- Absolute value.
+-- abs :: Num -> Num
+on abs(x)
+    if 0 > x then
+        -x
+    else
+        x
+    end if
+end abs
+
+-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b
+on bindLR(m, mf)
+    if missing value is not |Right| of m then
+        mReturn(mf)'s |λ|(|Right| of m)
+    else
+        m
+    end if
+end bindLR
+
+-- foldr :: (a -> b -> b) -> b -> [a] -> b
+on foldr(f, startValue, xs)
+    tell mReturn(f)
+        set v to startValue
+        set lng to length of xs
+        repeat with i from lng to 1 by -1
+            set v to |λ|(item i of xs, v, i, xs)
+        end repeat
+        return v
+    end tell
+end foldr
+
+-- id :: a -> a
+on |id|(x)
+    x
+end |id|
+
+-- justifyRight :: Int -> Char -> String -> String
+on justifyRight(n, cFiller, strText)
+    if n > length of strText then
+        text -n thru -1 of ((replicate(n, cFiller) as text) & strText)
+    else
+        strText
+    end if
+end justifyRight
+
+-- map :: (a -> b) -> [a] -> [b]
+on map(f, xs)
+    tell mReturn(f)
+        set lng to length of xs
+        set lst to {}
+        repeat with i from 1 to lng
+            set end of lst to |λ|(item i of xs, i, xs)
+        end repeat
+        return lst
+    end tell
+end map
+
+-- 'The mapAccumR function behaves like a combination of map and foldr;
+--  it applies a function to each element of a list, passing an accumulating
+--  parameter from |Right| to |Left|, and returning a final value of this
+--  accumulator together with the new list.' (see Hoogle)
+-- mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
+on mapAccumR(f, acc, xs)
+    script
+        on |λ|(x, a, i)
+            tell mReturn(f) to set pair to |λ|(|1| of a, x, i)
+            Tuple(|1| of pair, (|2| of pair) & |2| of a)
+        end |λ|
+    end script
+    foldr(result, Tuple(acc, []), xs)
+end mapAccumR
+
+-- min :: Ord a => a -> a -> a
+on min(x, y)
+    if y < x then
+        y
+    else
+        x
+    end if
+end min
+
+-- Lift 2nd class handler function into 1st class script wrapper
+-- mReturn :: First-class m => (a -> b) -> m (a -> b)
+on mReturn(f)
+    if class of f is script then
+        f
+    else
+        script
+            property |λ| : f
+        end script
+    end if
+end mReturn
+
+-- not :: Bool -> Bool
+on |not|(p)
+    not p
+end |not|
+
+-- Egyptian multiplication - progressively doubling a list, appending
+-- stages of doubling to an accumulator where needed for binary
+-- assembly of a target length
+-- replicate :: Int -> a -> [a]
+on replicate(n, a)
+    set out to {}
+    if n < 1 then return out
+    set dbl to {a}
+
+    repeat while (n > 1)
+        if (n mod 2) > 0 then set out to out & dbl
+        set n to (n div 2)
+        set dbl to (dbl & dbl)
+    end repeat
+    return out & dbl
+end replicate
+
+-- unlines :: [String] -> String
+on unlines(xs)
+    set {dlm, my text item delimiters} to ¬
+        {my text item delimiters, linefeed}
+    set str to xs as text
+    set my text item delimiters to dlm
+    str
+end unlines
+
+-- unwords :: [String] -> String
+on unwords(xs)
+    set {dlm, my text item delimiters} to {my text item delimiters, space}
+    set s to xs as text
+    set my text item delimiters to dlm
+    return s
+end unwords
+
+-- unwrap :: NSObject -> a
+on unwrap(objCValue)
+    if objCValue is missing value then
+        missing value
+    else
+        set ca to current application
+        item 1 of ((ca's NSArray's arrayWithObject:objCValue) as list)
+    end if
+end unwrap
+
+-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
+on zipWith(f, xs, ys)
+    set lng to min(length of xs, length of ys)
+    if 1 > lng then return {}
+    set lst to {}
+    tell mReturn(f)
+        repeat with i from 1 to lng
+            set end of lst to |λ|(item i of xs, item i of ys)
+        end repeat
+        return lst
+    end tell
+end zipWith

Task/Bitwise-operations/AppleScript/bitwise-operations-2.applescript

@@ -0,0 +1,488 @@
+use AppleScript version "2.4"
+use framework "Foundation"
+use scripting additions
+
+-- BITWISE OPERATIONS FOR APPLESCRIPT ---------------------------------------
+
+-- bitAND :: Int -> Int -> Int
+on bitAND(x, y)
+    bitOp2(my |and|, x, y)
+end bitAND
+
+-- bitOR :: Int -> Int -> Int
+on bitOR(x, y)
+    bitOp2(my |or|, x, y)
+end bitOR
+
+-- bitXOr :: Int -> Int -> Int
+on bitXOR(x, y)
+    bitOp2(my xor, x, y)
+end bitXOR
+
+-- bitNOT :: Int -> Int
+on bitNOT(x)
+    script notBits
+        on |λ|(xs)
+            bindLR(intFromBitsLR(map(my |not|, xs)), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(x), notBits)
+end bitNOT
+
+-- (<<) :: Int -> Int -> Int
+on |<<|(a, b)
+    script logicLshift
+        on |λ|(bs)
+            bindLR(intFromBitsLR(take(32, drop(b, bs) & replicate(b, false))), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(a), logicLshift)
+end |<<|
+
+-- Logical right shift
+-- (>>>) :: Int -> Int -> Int
+on |>>>|(a, b)
+    script logicRShift
+        on |λ|(bs)
+            bindLR(intFromBitsLR(take(32, replicate(b, false) & drop(b, bs))), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(a), logicRShift)
+end |>>>|
+
+-- Arithmetic right shift
+-- (>>) :: Int -> Int -> Int
+on |>>|(a, b)
+    script arithRShift
+        on |λ|(bs)
+            if 0 < length of bs then
+                set sign to item 1 of bs
+            else
+                set sign to false
+            end if
+            bindLR(intFromBitsLR(take(32, replicate(b, sign) & drop(b, bs))), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(a), arithRShift)
+
+end |>>|
+
+-- bitRotL :: Int -> Int -> Int
+on bitRotL(a, b)
+    script lRot
+        on |λ|(bs)
+            bindLR(intFromBitsLR(rotate(-b, bs)), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(a), lRot)
+end bitRotL
+
+-- bitRotR :: Int -> Int -> Int
+on bitRotR(a, b)
+    script rRot
+        on |λ|(bs)
+            bindLR(intFromBitsLR(rotate(b, bs)), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(a), rRot)
+end bitRotR
+
+-- TEST ---------------------------------------------------------------
+
+-- bitWise :: Int -> Int -> String
+on bitWise(a, b)
+    set labels to {"a AND b", "a OR b", "a XOR b", "NOT a", ¬
+        "a << b", "a >>> b", "a >> b", "ROTL a b", "ROTR a b"}
+    set xs to {bitAND(a, b), bitOR(a, b), bitXOR(a, b), bitNOT(a), ¬
+        |<<|(a, b), |>>>|(a, b), |>>|(a, b), bitRotL(a, b), bitRotR(a, b)}
+
+    script asBin
+        property arrow : " -> "
+        on |λ|(x, y)
+            justifyRight(8, space, x) & arrow & ¬
+                justifyRight(14, space, y as text) & arrow & showBinary(y)
+        end |λ|
+    end script
+
+    unlines({"32 bit signed integers   (in two's complement binary encoding)", "", ¬
+        unlines(zipWith(asBin, ¬
+            {"a = " & a as text, "b = " & b as text}, {a, b})), "", ¬
+        unlines(zipWith(asBin, labels, xs))})
+end bitWise
+
+on run
+    -- Assuming 32 bit signed integers (in two's complement binary encoding)
+
+    set strClip to bitWise(255, 170)
+    set the clipboard to strClip
+    strClip
+end run
+
+-- BINARY INTEGER CONVERSIONS AND DISPLAY  ------------------------------------------------------------------
+
+-- bitsFromInt :: Int -> Either String [Bool]
+on bitsFromIntLR(x)
+    script go
+        on |λ|(n, d, bools)
+            set xs to {0 ≠ d} & bools
+            if n > 0 then
+                |λ|(n div 2, n mod 2, xs)
+            else
+                xs
+            end if
+        end |λ|
+    end script
+
+    set a to abs(x)
+    if (2.147483647E+9) < a then
+        |Left|("Integer overflow – maximum is (2 ^ 31) - 1")
+    else
+        set bs to go's |λ|(a div 2, a mod 2, {})
+        if 0 > x then
+            |Right|(replicate(32 - (length of bs), true) & ¬
+                binSucc(map(my |not|, bs)))
+        else
+            set bs to go's |λ|(a div 2, a mod 2, {})
+            |Right|(replicate(32 - (length of bs), false) & bs)
+        end if
+    end if
+end bitsFromIntLR
+
+-- intFromBitsLR :: [Bool] -> Either String Int
+on intFromBitsLR(xs)
+    script bitSum
+        on |λ|(x, a, i)
+            if x then
+                a + (2 ^ (31 - i))
+            else
+                a
+            end if
+        end |λ|
+    end script
+
+    set lngBits to length of xs
+    if 32 < lngBits then
+        |Left|("Applescript limited to signed 32 bit integers")
+    else if 1 > lngBits then
+        |Right|(0 as integer)
+    else
+        set bits to (rest of xs)
+        if item 1 of xs then
+            |Right|(0 - foldr(bitSum, 1, map(my |not|, bits)) as integer)
+        else
+            |Right|(foldr(bitSum, 0, bits) as integer)
+        end if
+    end if
+end intFromBitsLR
+
+-- showBinary :: Int -> String
+on showBinary(x)
+    script showBin
+        on |λ|(xs)
+            script bChar
+                on |λ|(b)
+                    if b then
+                        "1"
+                    else
+                        "0"
+                    end if
+                end |λ|
+            end script
+
+            map(bChar, xs)
+        end |λ|
+    end script
+    bindLR(my bitsFromIntLR(x), showBin)
+end showBinary
+
+-- bitOp2 :: ((Bool -> Bool -> Bool) -> Int -> Int -> Int
+on bitOp2(f, x, y)
+    script yBits
+        on |λ|(bitX)
+            script zipOp
+                on |λ|(bitY)
+                    bitZipWithLR(f, bitX, bitY)
+                end |λ|
+            end script
+            bindLR(bindLR(bindLR(bitsFromIntLR(y), ¬
+                zipOp), my intFromBitsLR), my |id|)
+        end |λ|
+    end script
+    bindLR(bitsFromIntLR(x), yBits)
+end bitOp2
+
+-- bitZipWithLR ::  ((a, b) -> c ) -> [Bool] -> [Bool] -> Either String  [(Bool, Bool)]
+on bitZipWithLR(f, xs, ys)
+    set intX to length of xs
+    set intY to length of ys
+    set intMax to max(intX, intY)
+    if 33 > intMax then
+        if intX > intY then
+            set {bxs, bys} to {xs, ys & replicate(intX - intY, false)}
+        else
+            set {bxs, bys} to {xs & replicate(intY - intX, false), ys}
+        end if
+        tell mReturn(f)
+            set lst to {}
+            repeat with i from 1 to intMax
+                set end of lst to |λ|(item i of bxs, item i of bys)
+            end repeat
+            return |Right|(lst)
+        end tell
+    else
+        |Left|("Above maximum of 32 bits")
+    end if
+end bitZipWithLR
+
+-- Successor function (+1) for unsigned binary integer
+
+-- binSucc :: [Bool] -> [Bool]
+on binSucc(bs)
+    script succ
+        on |λ|(a, x)
+            if a then
+                if x then
+                    Tuple(a, false)
+                else
+                    Tuple(x, true)
+                end if
+            else
+                Tuple(a, x)
+            end if
+        end |λ|
+    end script
+
+    set tpl to mapAccumR(succ, true, bs)
+    if |1| of tpl then
+        {true} & |2| of tpl
+    else
+        |2| of tpl
+    end if
+end binSucc
+
+-- BOOLEANS  ----------------------------------------------------
+
+-- |or| :: Bool -> Bool -> Bool
+on |or|(x, y)
+    x or y
+end |or|
+
+-- |and| :: Bool -> Bool -> Bool
+on |and|(x, y)
+    x and y
+end |and|
+
+-- xor :: Bool -> Bool -> Bool
+on xor(x, y)
+    (x or y) and not (x and y)
+end xor
+
+-- not :: Bool -> Bool
+on |not|(p)
+    not p
+end |not|
+
+-- GENERAL ----------------------------------------------------
+
+-- Right :: b -> Either a b
+on |Right|(x)
+    {type:"Either", |Left|:missing value, |Right|:x}
+end |Right|
+
+-- Left :: a -> Either a b
+on |Left|(x)
+    {type:"Either", |Left|:x, |Right|:missing value}
+end |Left|
+
+-- Tuple (,) :: a -> b -> (a, b)
+on Tuple(a, b)
+    {type:"Tuple", |1|:a, |2|:b, length:2}
+end Tuple
+
+-- Absolute value.
+-- abs :: Num -> Num
+on abs(x)
+    if 0 > x then
+        -x
+    else
+        x
+    end if
+end abs
+
+-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b
+on bindLR(m, mf)
+    if missing value is not |Right| of m then
+        mReturn(mf)'s |λ|(|Right| of m)
+    else
+        m
+    end if
+end bindLR
+
+-- drop :: Int -> [a] -> [a]
+-- drop :: Int -> String -> String
+on drop(n, xs)
+    if class of xs is not string then
+        if n < length of xs then
+            items (1 + n) thru -1 of xs
+        else
+            {}
+        end if
+    else
+        if n < length of xs then
+            text (1 + n) thru -1 of xs
+        else
+            ""
+        end if
+    end if
+end drop
+
+-- foldr :: (a -> b -> b) -> b -> [a] -> b
+on foldr(f, startValue, xs)
+    tell mReturn(f)
+        set v to startValue
+        set lng to length of xs
+        repeat with i from lng to 1 by -1
+            set v to |λ|(item i of xs, v, i, xs)
+        end repeat
+        return v
+    end tell
+end foldr
+
+-- id :: a -> a
+on |id|(x)
+    x
+end |id|
+
+-- justifyRight :: Int -> Char -> String -> String
+on justifyRight(n, cFiller, strText)
+    if n > length of strText then
+        text -n thru -1 of ((replicate(n, cFiller) as text) & strText)
+    else
+        strText
+    end if
+end justifyRight
+
+-- map :: (a -> b) -> [a] -> [b]
+on map(f, xs)
+    tell mReturn(f)
+        set lng to length of xs
+        set lst to {}
+        repeat with i from 1 to lng
+            set end of lst to |λ|(item i of xs, i, xs)
+        end repeat
+        return lst
+    end tell
+end map
+
+-- 'The mapAccumR function behaves like a combination of map and foldr;
+--  it applies a function to each element of a list, passing an accumulating
+--  parameter from |Right| to |Left|, and returning a final value of this
+--  accumulator together with the new list.' (see Hoogle)
+-- mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
+on mapAccumR(f, acc, xs)
+    script
+        on |λ|(x, a, i)
+            tell mReturn(f) to set pair to |λ|(|1| of a, x, i)
+            Tuple(|1| of pair, (|2| of pair) & |2| of a)
+        end |λ|
+    end script
+    foldr(result, Tuple(acc, []), xs)
+end mapAccumR
+
+-- max :: Ord a => a -> a -> a
+on max(x, y)
+    if x > y then
+        x
+    else
+        y
+    end if
+end max
+
+-- min :: Ord a => a -> a -> a
+on min(x, y)
+    if y < x then
+        y
+    else
+        x
+    end if
+end min
+
+-- Lift 2nd class handler function into 1st class script wrapper
+-- mReturn :: First-class m => (a -> b) -> m (a -> b)
+on mReturn(f)
+    if class of f is script then
+        f
+    else
+        script
+            property |λ| : f
+        end script
+    end if
+end mReturn
+
+-- Egyptian multiplication - progressively doubling a list, appending
+-- stages of doubling to an accumulator where needed for binary
+-- assembly of a target length
+-- replicate :: Int -> a -> [a]
+on replicate(n, a)
+    set out to {}
+    if n < 1 then return out
+    set dbl to {a}
+
+    repeat while (n > 1)
+        if (n mod 2) > 0 then set out to out & dbl
+        set n to (n div 2)
+        set dbl to (dbl & dbl)
+    end repeat
+    return out & dbl
+end replicate
+
+-- rotate :: Int -> [a] -> [a]
+on rotate(n, xs)
+    set lng to length of xs
+    if 0 > n then
+        set d to (-n) mod lng
+    else
+        set d to lng - (n mod lng)
+    end if
+    drop(d, xs) & take(d, xs)
+end rotate
+
+-- take :: Int -> [a] -> [a]
+-- take :: Int -> String -> String
+on take(n, xs)
+    if class of xs is string then
+        if 0 < n then
+            text 1 thru min(n, length of xs) of xs
+        else
+            ""
+        end if
+    else
+        if 0 < n then
+            items 1 thru min(n, length of xs) of xs
+        else
+            {}
+        end if
+    end if
+end take
+
+-- unlines :: [String] -> String
+on unlines(xs)
+    set {dlm, my text item delimiters} to ¬
+        {my text item delimiters, linefeed}
+    set str to xs as text
+    set my text item delimiters to dlm
+    str
+end unlines
+
+-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
+on zipWith(f, xs, ys)
+    set lng to min(length of xs, length of ys)
+    if 1 > lng then return {}
+    set lst to {}
+    tell mReturn(f)
+        repeat with i from 1 to lng
+            set end of lst to |λ|(item i of xs, item i of ys)
+        end repeat
+        return lst
+    end tell
+end zipWith

Task/Bitwise-operations/BASIC/bitwise-operations-3.basic

@@ -1,9 +1,6 @@
-           org   4084
-3a 83 40   ld    a, (4083)
-47         ld    b, a
-3a 82 40   ld    a, (4082)
-a0         and   b
-00         nop            ; negate and shift instructions take 2 bytes
-06 00      ld    b, 0
-4f         ld    c, a     ; value in BC reg pair is returned to BASIC
-c9         ret
+10 INPUT "A="; A
+20 INPUT "B="; B
+30 PRINT "A AND B =" A AND B    :rem AND
+40 PRINT "A OR B =" A OR B      :rem OR
+50 PRINT "A XOR B =" (A AND(NOT B))OR((NOT A)AND B)    :rem XOR
+60 PRINT "NOT A =" NOT A        :rem NOT

Task/Bitwise-operations/BASIC/bitwise-operations-4.basic

@@ -1,25 +1,8 @@
- 10 REM ABCDEFGHIJKLMNO
- 20 INPUT A
- 30 INPUT B
- 40 POKE 16514,A
- 50 POKE 16515,B
- 60 LET ADDR=16516
- 70 LET R$="3A8340473A8240A00006004FC9"
- 80 POKE ADDR,CODE R$*16+CODE R$(2)-476
- 90 LET R$=R$(3 TO )
-100 LET ADDR=ADDR+1
-110 IF R$<>"" THEN GOTO 80
-120 PRINT A;" AND ";B;" = ";USR 16516
-130 POKE 16523,176
-140 PRINT A;" OR ";B;" = ";USR 16516
-150 POKE 16523,168
-160 PRINT A;" XOR ";B;" = ";USR 16516
-170 POKE 16523,237
-180 POKE 16524,68
-190 PRINT "NOT ";A;" = ";USR 16516
-200 POKE 16523,203
-210 POKE 16524,39
-220 FOR I=1 TO B
-230 POKE 16514,USR 16516
-240 NEXT I
-250 PRINT A;" << ";B;" = ";PEEK 16514
+100 LET A=10:LET B=12
+110 PRINT A;"and";B;"=";A AND B
+120 PRINT A;"band";B;"=";A BAND B
+130 PRINT A;"or ";B;"=";A OR B
+140 PRINT A;"bor";B;"=";A BOR B
+150 PRINT A;"xor";B;"=";XOR(A,B)
+160 PRINT " not";A;"=";NOT A
+170 DEF XOR(A,B)=(A BOR B)-(A BAND B)

Task/Bitwise-operations/BASIC/bitwise-operations-5.basic

@@ -0,0 +1,9 @@
+           org   4084
+3a 83 40   ld    a, (4083)
+47         ld    b, a
+3a 82 40   ld    a, (4082)
+a0         and   b
+00         nop            ; negate and shift instructions take 2 bytes
+06 00      ld    b, 0
+4f         ld    c, a     ; value in BC reg pair is returned to BASIC
+c9         ret

Task/Bitwise-operations/BASIC/bitwise-operations-6.basic

@@ -0,0 +1,25 @@
+ 10 REM ABCDEFGHIJKLMNO
+ 20 INPUT A
+ 30 INPUT B
+ 40 POKE 16514,A
+ 50 POKE 16515,B
+ 60 LET ADDR=16516
+ 70 LET R$="3A8340473A8240A00006004FC9"
+ 80 POKE ADDR,CODE R$*16+CODE R$(2)-476
+ 90 LET R$=R$(3 TO )
+100 LET ADDR=ADDR+1
+110 IF R$<>"" THEN GOTO 80
+120 PRINT A;" AND ";B;" = ";USR 16516
+130 POKE 16523,176
+140 PRINT A;" OR ";B;" = ";USR 16516
+150 POKE 16523,168
+160 PRINT A;" XOR ";B;" = ";USR 16516
+170 POKE 16523,237
+180 POKE 16524,68
+190 PRINT "NOT ";A;" = ";USR 16516
+200 POKE 16523,203
+210 POKE 16524,39
+220 FOR I=1 TO B
+230 POKE 16514,USR 16516
+240 NEXT I
+250 PRINT A;" << ";B;" = ";PEEK 16514

Task/Bitwise-operations/Elena/bitwise-operations.elena

@@ -1,19 +1,19 @@
-import extensions.
+import extensions;
 
 extension testOp
 {
-    bitwiseTest : y
-    [
-        console printLine(self," and ",y," = ",self and:y).
-        console printLine(self," or ",y," = ",self or:y).
-        console printLine(self," xor ",y," = ",self xor:y).
-        console printLine("not ",self," = ",self inverted).
-        console printLine(self," shr ",y," = ",self shiftRight:y).
-        console printLine(self," shl ",y," = ",self shiftLeft:y).
-    ]
+    bitwiseTest(y)
+    {
+        console.printLine(self," and ",y," = ",self.and(y));
+        console.printLine(self," or ",y," = ",self.or(y));
+        console.printLine(self," xor ",y," = ",self.xor(y));
+        console.printLine("not ",self," = ",self.Inverted);
+        console.printLine(self," shr ",y," = ",self.shiftRight(y));
+        console.printLine(self," shl ",y," = ",self.shiftLeft(y));
+    }
 }
 
-public program =
-[
-    console readLineTo(Integer new); bitwiseTest(console readLineTo(Integer new)).
-].
+public program()
+{
+    console.loadLineTo(new Integer()).bitwiseTest(console.loadLineTo(new Integer()))
+}

Task/Bitwise-operations/Free-Pascal/bitwise-operations.free

@@ -0,0 +1,19 @@
+program Bitwise;
+{$mode objfpc}
+var
+  // Pascal uses a native int type as a default literal type
+  // Make sure the operants work on an exact type.
+  x:shortint = 2;
+  y:ShortInt = 3;
+begin
+  Writeln('2 and 3 = ', x and y);
+  Writeln('2 or 3 = ', x or y);
+  Writeln('2 xor 3 = ', x xor y);
+  Writeln('not 2 = ', not x);
+  Writeln('2 shl 3 = ', x >> y);
+  Writeln('2 shr 3 = ', x << y);
+  writeln('2 rol 3 = ', rolbyte(x,y));
+  writeln('2 ror 3 = ', rorbyte(x,y));
+  writeln('2 sar 3 = ', sarshortint(x,y));
+  Readln;
+end.

Task/Bitwise-operations/Neko/bitwise-operations.neko

@@ -0,0 +1,57 @@
+/**
+ <doc>
+   <h2>bitwise operations</h2>
+   <p>Tectonics:
+     <br>  nekoc bitwise.neko
+     <br>  neko bitwise</p>
+ </doc>
+*/
+
+// Neko is a signed 31 bit integer VM, full 32 bit requires builtins
+var int32_new = $loader.loadprim("std@int32_new", 1);
+var int32_and = $loader.loadprim("std@int32_and", 2);
+var int32_or = $loader.loadprim("std@int32_or", 2);
+var int32_xor = $loader.loadprim("std@int32_xor", 2);
+var int32_shl = $loader.loadprim("std@int32_shl", 2);
+var int32_shr = $loader.loadprim("std@int32_shr", 2);
+var int32_ushr = $loader.loadprim("std@int32_ushr", 2);
+var int32_complement = $loader.loadprim("std@int32_complement", 1);
+
+// Function to show bitwise operations on a,b
+var bitwise = function(a, b) {
+  var ia = int32_new(a);
+  var ib = int32_new(b);
+
+  $print("Neko 32 bit integer library\n");
+  $print("a AND b: ", a, " ", b, " ", int32_and(ia, ib), "\n");
+  $print("a OR b:  ", a, " ", b, " ", int32_or(ia, ib), "\n");
+  $print("a XOR b: ", a, " ", b, " ", int32_xor(ia, ib), "\n");
+  $print("ones complement a:   ", a, " ", int32_complement(ia), "\n");
+  $print("a SHL b: ", a, " ", b, " ", int32_shl(ia, ib), "\n");
+  $print("a SHR b: ", a, " ", b, " ", int32_shr(ia, ib), "\n");
+  $print("a USHR b: ", a, " ", b, " ", int32_ushr(ia, ib), "\n");
+  $print("a ROL b: is not directly supported in Neko Int32\n");
+  $print("a ROR b: is not directly supported in Neko Int32\n");
+
+  $print("\nNormal Neko 31 bit signed integers\n");
+  a = $int(a);
+  b = $int(b);
+  $print("a AND b: ", a, " ", b, " ", a & b, "\n");
+  $print("a OR  b: ", a, " ", b, " ", a | b, "\n");
+  $print("a XOR b: ", a, " ", b, " ", a ^ b, "\n");
+  $print("NOT a: is not directly supported in Neko syntax\n");
+  $print("a SHL b: ", a, " ", b, " ", a << b, "\n");
+  $print("a SHR b: ", a, " ", b, " ", a >> b, "\n");
+  $print("a USHR b: ", a, " ", b, " ", a >>> b, "\n");
+  $print("a ROL b: is not directly supported in Neko syntax\n");
+  $print("a ROR b: is not directly supported in Neko syntax\n");
+}
+
+// Pass command line arguments to the demo function
+// initially as float, to ensure no internal bit truncation
+var a = $float($loader.args[0]);
+var b = $float($loader.args[1]);
+if a == null a = 0;
+if b == null b = 0;
+
+bitwise(a,b);

Task/Bitwise-operations/Robotic/bitwise-operations.robotic

@@ -0,0 +1,15 @@
+input string "First value"
+set "local1" to "input"
+input string "Second value"
+set "local2" to "input"
+
+. ">>> is an arithmetic shift; >> is a logical shift"
+[ "a AND b = ('local1' a 'local2')"
+[ "a OR b = ('local1' o 'local2')"
+[ "a XOR b = ('local1' x 'local2')"
+[ "NOT a = (~'local1')"
+[ "a << b = ('local1' << 'local2')"
+[ "a >> b = ('local1' >> 'local2')"
+[ "a >>> b = ('local1' >>> 'local2')"
+end
+. "Bitwise rotation is not natively supported"

Task/Bitwise-operations/Simula/bitwise-operations.simula

@@ -0,0 +1,102 @@
+BEGIN
+   COMMENT TO MY KNOWLEDGE SIMULA DOES NOT SUPPORT BITWISE OPERATIONS SO WE MUST WRITE PROCEDURES FOR THE JOB ;
+   INTEGER WORDSIZE;
+   WORDSIZE := 32;
+   BEGIN
+
+      PROCEDURE TOBITS(N,B); INTEGER N; BOOLEAN ARRAY B;
+      BEGIN
+         INTEGER I,BITN;
+         FOR I := WORDSIZE-1 STEP -1 UNTIL 0 DO BEGIN
+            BITN := MOD(N,2); B(I) := BITN<>0; N := N // 2;
+         END;
+      END TOBITS;
+
+      INTEGER PROCEDURE FROMBITS(B); BOOLEAN ARRAY B;
+      BEGIN
+         INTEGER I, RESULT;
+         FOR I := 0 STEP 1 UNTIL WORDSIZE-1 DO
+             RESULT := 2 * RESULT + (IF B(I) THEN 1 ELSE 0);
+         FROMBITS := RESULT;
+      END FROMBITS;
+
+      INTEGER PROCEDURE BITOP(A,B,F);
+         INTEGER A,B;
+         PROCEDURE F IS BOOLEAN PROCEDURE F(A,B); BOOLEAN A,B;;
+      BEGIN
+         INTEGER I;
+         BOOLEAN ARRAY BA(0:WORDSIZE-1);
+         BOOLEAN ARRAY BB(0:WORDSIZE-1);
+         TOBITS(A,BA);
+         TOBITS(B,BB);
+         FOR I := 0 STEP 1 UNTIL WORDSIZE-1 DO BA(I) := F(BA(I),BB(I));
+         BITOP := FROMBITS(BA);
+      END BITOP;
+
+      INTEGER PROCEDURE BITUOP(A,F);
+         INTEGER A;
+         PROCEDURE F IS BOOLEAN PROCEDURE F(A); BOOLEAN A;;
+      BEGIN
+         INTEGER I;
+         BOOLEAN ARRAY BA(0:WORDSIZE-1);
+         TOBITS(A,BA);
+         FOR I := 0 STEP 1 UNTIL WORDSIZE-1 DO BA(I) := F(BA(I));
+         BITUOP := FROMBITS(BA);
+      END BITUOP;
+
+      BOOLEAN PROCEDURE OPAND(A,B); BOOLEAN A,B; OPAND := A AND B;
+      INTEGER PROCEDURE BITAND(A,B); INTEGER A,B; BITAND := BITOP(A,B,OPAND);
+
+      BOOLEAN PROCEDURE OPOR(A,B); BOOLEAN A,B; OPOR := A OR B;
+      INTEGER PROCEDURE BITOR(A,B); INTEGER A,B; BITOR := BITOP(A,B,OPOR);
+
+      BOOLEAN PROCEDURE OPXOR(A,B); BOOLEAN A,B; OPXOR := (A AND NOT B) OR (NOT A AND B);
+      INTEGER PROCEDURE BITXOR(A,B); INTEGER A,B; BITXOR := BITOP(A,B,OPXOR);
+
+      BOOLEAN PROCEDURE OPNOT(A); BOOLEAN A; OPNOT := NOT A;
+      INTEGER PROCEDURE BITNOT(A); INTEGER A; BITNOT := BITUOP(A,OPNOT);
+
+      INTEGER PROCEDURE BITSHL(A,B); INTEGER A,B;
+      BEGIN
+          IF B < 0 THEN A := BITSHR(A,-B)
+          ELSE WHILE B > 0 DO BEGIN A := 2 * A; B := B-1; END;
+          BITSHL := A;
+      END BITSHL;
+
+      INTEGER PROCEDURE BITSHR(A,B); INTEGER A,B;
+      BEGIN
+          IF B < 0 THEN A := BITSHL(A,-B)
+          ELSE WHILE B > 0 DO BEGIN A := A // 2; B := B-1; END;
+          BITSHR := A;
+      END BITSHR;
+
+      INTEGER PROCEDURE BITROTR(A,B); INTEGER A,B;
+      BEGIN
+         INTEGER I,J;
+         BOOLEAN ARRAY BA(0:WORDSIZE-1);
+         BOOLEAN ARRAY BB(0:WORDSIZE-1);
+         TOBITS(A,BA);
+         FOR I := 0 STEP 1 UNTIL WORDSIZE-1 DO BEGIN
+            J := MOD(I + B, WORDSIZE); BB(J) := BA(I);
+         END;
+         BITROTR := FROMBITS(BB);
+      END BITROTR;
+
+      INTEGER PROCEDURE BITROTL(A,B); INTEGER A,B;
+         BITROTL := BITROTR(A,-B);
+
+      PROCEDURE BITWISE(A,B); INTEGER A,B;
+      BEGIN
+        OUTTEXT("A AND B   : "); OUTINT(BITAND(A,B),0); OUTIMAGE;
+        OUTTEXT("A OR B    : "); OUTINT(BITOR (A,B),0); OUTIMAGE;
+        OUTTEXT("A XOR B   : "); OUTINT(BITXOR(A,B),0); OUTIMAGE;
+        OUTTEXT("NOT A     : "); OUTINT(BITNOT(A),  0); OUTIMAGE;
+        OUTTEXT("A << B    : "); OUTINT(BITSHL(A,B),0); OUTIMAGE;  ! LEFT SHIFT ;
+        OUTTEXT("A >> B    : "); OUTINT(BITSHR(A,B),0); OUTIMAGE;  ! ARITHMETIC RIGHT SHIFT ;
+        OUTTEXT("A ROTL B  : "); OUTINT(BITROTL(A,B),0); OUTIMAGE;  ! ROTATE LEFT ;
+        OUTTEXT("A ROTR B  : "); OUTINT(BITROTR(A,B),0); OUTIMAGE;  ! ROTATE RIGHT ;
+      END BITWISE;
+
+      BITWISE(14,3);
+   END;
+END