2016 Update

Task/Catamorphism/00DESCRIPTION

@@ -1,7 +1,11 @@
 ''Reduce'' is a function or method that is used to take the values in an array or a list and apply a function to successive members of the list to produce (or reduce them to), a single value.
 
+
+;Task:
 Show how ''reduce'' (or ''foldl'' or ''foldr'' etc), work (or would be implemented) in your language.
 
+
 ;Cf.
 * [[wp:Fold (higher-order function)|Fold]]
 * [[wp:Catamorphism|Catamorphism]]
+<br><br>

Task/Catamorphism/ALGOL-68/catamorphism.alg

@@ -0,0 +1,20 @@
+# applies fn to successive elements of the array of values #
+# the result is 0 if there are no values                   #
+PROC reduce = ( []INT values, PROC( INT, INT )INT fn )INT:
+     IF UPB values < LWB values
+     THEN # no elements #
+          0
+     ELSE # there are some elements #
+          INT result := values[ LWB values ];
+          FOR pos FROM LWB values + 1 TO UPB values
+          DO
+              result := fn( result, values[ pos ] )
+          OD;
+          result
+     FI; # reduce #
+
+# test the reduce procedure #
+BEGIN print( ( reduce( ( 1, 2, 3, 4, 5 ), ( INT a, b )INT: a + b ), newline ) ) # sum #
+    ; print( ( reduce( ( 1, 2, 3, 4, 5 ), ( INT a, b )INT: a * b ), newline ) ) # product #
+    ; print( ( reduce( ( 1, 2, 3, 4, 5 ), ( INT a, b )INT: a - b ), newline ) ) # difference #
+END

Task/Catamorphism/AppleScript/catamorphism.applescript

@@ -0,0 +1,76 @@
+-- the arguments available to the called function f(a, x, i, l) are
+-- a: current accumulator value
+-- x: current item in list
+-- i: [ 1-based index in list ] optional
+-- l: [ a reference to the list itself ] optional
+
+-- reduce :: (a -> b -> a) -> a -> [b] -> a
+on reduce(f, startValue, xs)
+    tell mReturn(f)
+        set v to startValue
+        set lng to length of xs
+        repeat with i from 1 to lng
+            set v to lambda(v, item i of xs, i, xs)
+        end repeat
+        return v
+    end tell
+end reduce
+
+
+-- the arguments available to the called function f(a, x, i, l) are
+-- a: current accumulator value
+-- x: current item in list
+-- i: [ 1-based index in list ] optional
+-- l: [ a reference to the list itself ] optional
+
+-- reduceRight :: (a -> b -> a) -> a -> [b] -> a
+on reduceRight(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 lambda(v, item i of xs, i, xs)
+        end repeat
+        return v
+    end tell
+end reduceRight
+
+
+-- TEST
+on run
+    set lst to {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}
+
+    {reduce(sum_, 0, lst), ¬
+        reduce(product_, 1, lst), ¬
+        reduceRight(append_, "", lst)}
+
+    --> {55, 3628800, "10987654321"}
+end run
+
+on sum_(a, b)
+    a + b
+end sum_
+
+on product_(a, b)
+    a * b
+end product_
+
+on append_(a, b)
+    a & b
+end append_
+
+
+
+-- GENERIC
+
+-- Lift 2nd class handler function into 1st class script wrapper
+-- mReturn :: Handler -> Script
+on mReturn(f)
+    if class of f is script then
+        f
+    else
+        script
+            property lambda : f
+        end script
+    end if
+end mReturn

Task/Catamorphism/Elena/catamorphism.elena

@@ -0,0 +1,18 @@
+#import system.
+#import system'collections.
+#import system'routines.
+#import extensions.
+#import extensions'text.
+
+#symbol program =
+[
+    #var numbers := 1 repeat &till:10 &each:n [ n ] summarize:(ArrayList new).
+
+    #var summary := numbers accumulate:(Variable new:0) &with:(:a:b) [ a + b ].
+
+    #var product := numbers accumulate:(Variable new:1) &with:(:a:b) [ a * b ].
+
+    #var concatenation := numbers accumulate:(String new) &with:(:a:b) [ a literal + b literal ].
+
+    console writeLine:summary:" ":product:" ":concatenation.
+].

Task/Catamorphism/Forth/catamorphism-1.fth

@@ -0,0 +1,5 @@
+: lowercase? ( c -- f )
+  [char] a [ char z 1+ ] literal within ;
+
+: char-upcase ( c -- C )
+  dup lowercase? if bl xor then ;

Task/Catamorphism/Forth/catamorphism-2.fth

@@ -0,0 +1,19 @@
+: string-at ( c-addr u +n -- c )
+  nip + c@ ;
+: string-at! ( c-addr u +n c -- )
+  rot drop  -rot  + c! ;
+
+: type-lowercase ( c-addr u -- )
+  dup 0 ?do
+    2dup i string-at  dup lowercase?  if emit else drop then
+  loop  2drop ;
+
+: upcase ( 'string' -- 'STRING' )
+  dup 0 ?do
+    2dup 2dup  i string-at  char-upcase  i swap string-at!
+  loop ;
+
+: count-lowercase ( c-addr u -- n )
+  0 -rot dup 0 ?do
+    2dup i string-at  lowercase? if rot 1+ -rot then
+  loop  2drop ;

Task/Catamorphism/Forth/catamorphism-3.fth

@@ -0,0 +1,8 @@
+: next-char ( a +n -- a' n' c -1 )  ( a 0 -- 0 )
+  dup if 2dup  1 /string  2swap drop c@ true
+  else 2drop 0 then ;
+
+: type-lowercase ( c-addr u -- )
+  begin next-char while
+    dup lowercase? if emit else drop then
+  repeat ;

Task/Catamorphism/Forth/catamorphism-4.fth

@@ -0,0 +1,17 @@
+: each-char[ ( c-addr u -- )
+  postpone BOUNDS postpone ?DO
+  postpone I postpone C@ ;  immediate
+
+  \ interim code: ( c -- )
+
+: ]each-char ( -- )
+  postpone LOOP ;  immediate
+
+: type-lowercase ( c-addr u -- )
+  each-char[ dup lowercase? if emit else drop then ]each-char ;
+
+: upcase ( 'string' -- 'STRING' )
+  2dup each-char[ char-upcase i c! ]each-char ;
+
+: count-lowercase ( c-addr u -- n )
+  0 -rot each-char[ lowercase? if 1+ then ]each-char ;

Task/Catamorphism/Forth/catamorphism-5.fth

@@ -0,0 +1,17 @@
+: each-char ( c-addr u xt -- )
+  {: xt :}  bounds ?do
+    i c@ xt execute
+  loop ;
+
+: type-lowercase ( c-addr u -- )
+  [: dup lowercase? if emit else drop then ;]
+  each-char ;
+
+\ producing a new string
+: upcase ( 'string' -- 'STRING' )
+  dup cell+ allocate throw -rot
+  [: ( new-string-addr c -- new-string-addr )
+    upcase over c+! ;] each-char  $@ ;
+
+: count-lowercase ( c-addr u -- n )
+  0 -rot [: lowercase? if 1+ then ;] each-char ;

Task/Catamorphism/Groovy/catamorphism.groovy

@@ -0,0 +1,13 @@
+def vector1 = [1,2,3,4,5,6,7]
+def vector2 = [7,6,5,4,3,2,1]
+def map1 = [a:1, b:2, c:3, d:4]
+
+println vector1.inject { acc, val -> acc + val }       // sum
+println vector1.inject { acc, val -> acc + val*val }   // sum of squares
+println vector1.inject { acc, val -> acc * val }       // product
+println vector1.inject { acc, val -> acc<val?val:acc } // max
+println ([vector1,vector2].transpose().inject(0) { acc, val -> acc + val[0]*val[1] }) //dot product (with seed 0)
+
+println (map1.inject { Map.Entry accEntry, Map.Entry entry ->     // some sort of weird map-based reduction
+    [(accEntry.key + entry.key):accEntry.value + entry.value ].entrySet().toList().pop()
+})

Task/Catamorphism/JavaScript/catamorphism-2.js

@@ -0,0 +1,21 @@
+(function (xs) {
+    'use strict';
+
+    // foldl :: (b -> a -> b) -> b -> [a] -> b
+    function foldl(f, acc, xs) {
+        return xs.reduce(f, acc);
+    }
+
+    // foldr :: (b -> a -> b) -> b -> [a] -> b
+    function foldr(f, acc, xs) {
+        return xs.reduceRight(f, acc);
+    }
+
+    // Test folds in both directions
+    return [foldl, foldr].map(function (f) {
+        return f(function (acc, x) {
+            return acc + (x * 2).toString() + ' ';
+        }, [], xs);
+    });
+
+})([0, 1, 2, 3, 4, 5, 6, 7, 8, 9]);

Task/Catamorphism/JavaScript/catamorphism-3.js

@@ -0,0 +1,5 @@
+var nums = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10];
+
+console.log(nums.reduce((a, b) => a + b, 0)); // sum of 1..10
+console.log(nums.reduce((a, b) => a * b, 1)); // product of 1..10
+console.log(nums.reduce((a, b) => a + b, '')); // concatenation of 1..10

Task/Catamorphism/Lua/catamorphism.lua

@@ -0,0 +1,29 @@
+table.unpack = table.unpack or unpack -- 5.1 compatibility
+local nums = {1,2,3,4,5,6,7,8,9}
+
+function add(a,b)
+   return a+b
+end
+
+function mult(a,b)
+   return a*b
+end
+
+function cat(a,b)
+   return tostring(a)..tostring(b)
+end
+
+local function reduce(fun,a,b,...)
+   if ... then
+      return reduce(fun,fun(a,b),...)
+   else
+      return fun(a,b)
+   end
+end
+
+local arithmetic_sum = function (...) return reduce(add,...) end
+local factorial5 = reduce(mult,5,4,3,2,1)
+
+print("Σ(1..9)   : ",arithmetic_sum(table.unpack(nums)))
+print("5!        : ",factorial5)
+print("cat {1..9}: ",reduce(cat,table.unpack(nums)))

Task/Catamorphism/Objeck/catamorphism.objeck

@@ -0,0 +1,17 @@
+use Collection;
+
+class Reducer {
+  function : Main(args : String[]) ~ Nil {
+    values := IntVector->New([1, 2, 3, 4, 5]);
+    values->Reduce(Add(Int, Int) ~ Int)->PrintLine();
+    values->Reduce(Mul(Int, Int) ~ Int)->PrintLine();
+  }
+
+  function : Add(a : Int, b : Int) ~ Int {
+    return a + b;
+  }
+
+  function : Mul(a : Int, b : Int) ~ Int {
+    return a * b;
+  }
+}

Task/Catamorphism/PowerShell/catamorphism.psh

@@ -0,0 +1 @@
+1..5 | ForEach-Object -Begin {$result = 0} -Process {$result += $_} -End {$result}

Task/Catamorphism/REXX/catamorphism.rexx

@@ -1,36 +1,36 @@
-/*REXX pgm shows a method for  catamorphism  for some simple functions. */
-@list = 1 2 3 4 5 6 7 8 9 10
-                               say 'show:'  fold(@list, 'show')
-                               say ' sum:'  fold(@list, '+')
-                               say 'prod:'  fold(@list, '*')
-                               say ' cat:'  fold(@list, '||')
-                               say ' min:'  fold(@list, 'min')
-                               say ' max:'  fold(@list, 'max')
-                               say ' avg:'  fold(@list, 'avg')
-                               say ' GCD:'  fold(@list, 'GCD')
-                               say ' LCM:'  fold(@list, 'LCM')
-exit                                   /*stick a fork in it, we're done.*/
-/*──────────────────────────────────FOLD subroutine─────────────────────*/
-fold: procedure;  parse arg z; arg ,f;   z=space(z)   /*F is uppercased.*/
-za=translate(z, f, " ");     zf=f'('translate(z,',' ," ")')'
-if f=='+'   | f=='*'    then interpret 'return' za
-if f=='||'              then return space(z,0)
-if f=='AVG'             then interpret 'return' fold(z,'+') "/" words(z)
-if wordpos(f,'MIN MAX LCM GCD')\==0    then interpret 'return' zf
-if f=='SHOW'            then return z
-return 'illegal function:' arg(2)
-/*──────────────────────────────────LCM subroutine──────────────────────*/
-lcm:  procedure;  $=;                  do j=1  for arg(); $=$ arg(j);  end
-x=abs(word($,1))                       /* [↑] build a list of arguments.*/
-            do k=2  to words($);   !=abs(word($,k));  if !=0 then return 0
-            x=x*! / gcd(x,!)           /*have  GCD do the heavy lifting.*/
-            end   /*k*/
-return x                               /*return with the money.         */
-/*──────────────────────────────────GCD subroutine──────────────────────*/
-gcd:  procedure;  $=;                  do j=1  for arg(); $=$ arg(j);  end
-parse var $ x z .;   if x=0 then x=z   /* [↑] build a list of arguments.*/
-x=abs(x)
-            do k=2  to words($);    y=abs(word($,k));  if y=0 then iterate
-              do until _==0;   _=x//y;   x=y;   y=_;   end   /*until*/
-            end   /*k*/
-return x                               /*return with the money.         */
+/*REXX program demonstrates a  method  for  catamorphism  for some simple functions.    */
+@list= 1 2 3 4 5 6 7 8 9 10
+                               say 'show:'    fold(@list,  "show")
+                               say ' sum:'    fold(@list,  "+"   )
+                               say 'prod:'    fold(@list,  "*"   )
+                               say ' cat:'    fold(@list,  "||"  )
+                               say ' min:'    fold(@list,  "min" )
+                               say ' max:'    fold(@list,  "max" )
+                               say ' avg:'    fold(@list,  "avg" )
+                               say ' GCD:'    fold(@list,  "GCD" )
+                               say ' LCM:'    fold(@list,  "LCM" )
+exit                                             /*stick a fork in it,  we're all done. */
+/*──────────────────────────────────────────────────────────────────────────────────────*/
+fold: procedure;  parse arg z;  arg ,f;        z=space(z);          BIFs='MIN MAX LCM GCD'
+      za=translate(z, f, ' ');                 zf=f"("translate(z, ',' , " ")')'
+      if f=='+' | f=="*"       then interpret  "return"  za
+      if f=='||'               then return space(z, 0)
+      if f=='AVG'              then interpret  "return"  fold(z, '+')    "/"    words(z)
+      if wordpos(f,BIFs)\==0   then interpret  "return"  zf
+      if f=='SHOW'             then return z
+      return 'illegal function:'   arg(2)
+/*──────────────────────────────────────────────────────────────────────────────────────*/
+GCD:  procedure;  $=;                           do j=1  for arg();  $=$ arg(j);  end /*j*/
+      parse var $ x z .;   if x=0  then x=z            /* [↑] build a list of arguments.*/
+      x=abs(x)
+                       do k=2  to words($);     y=abs(word($,k));    if y==0  then iterate
+                         do until _==0;   _=x//y;   x=y;   y=_;   end  /*until*/
+                       end   /*k*/
+      return x
+/*──────────────────────────────────────────────────────────────────────────────────────*/
+LCM:  procedure;  $=;                           do j=1  for arg();  $=$ arg(j);  end /*j*/
+      x=abs(word($,1))                                 /* [↑] build a list of arguments.*/
+                       do k=2  to words($);     !=abs(word($,k));   if !==0  then return 0
+                       x=x*! / GCD(x,!)                /*have  GCD do the heavy lifting.*/
+                       end   /*k*/
+      return x

Task/Catamorphism/ZX-Spectrum-Basic/catamorphism.zx

@@ -0,0 +1,15 @@
+10 DIM a(5)
+20 FOR i=1 TO 5
+30 READ a(i)
+40 NEXT i
+50 DATA 1,2,3,4,5
+60 LET o$="+": GO SUB 1000: PRINT tmp
+70 LET o$="-": GO SUB 1000: PRINT tmp
+80 LET o$="*": GO SUB 1000: PRINT tmp
+90 STOP
+1000 REM Reduce
+1010 LET tmp=a(1)
+1020 FOR i=2 TO 5
+1030 LET tmp=VAL ("tmp"+o$+"a(i)")
+1040 NEXT i
+1050 RETURN