2016 Update

Task/Man-or-boy-test/00DESCRIPTION

@@ -1,3 +1,4 @@
+<br>
 '''Background''': The '''man or boy test''' was proposed by computer scientist [[wp:Donald_Knuth|Donald Knuth]] as a means of evaluating implementations of the [[:Category:ALGOL 60|ALGOL 60]] programming language. The aim of the test was to distinguish compilers that correctly implemented "recursion and non-local references" from those that did not.
 
 <blockquote style="font-style:italic">
@@ -217,3 +218,4 @@ The table below shows the result, call depths, and total calls for a range of ''
 |&nbsp;
 |&nbsp;
 |}
+<br><br>

Task/Man-or-boy-test/Ada/man-or-boy-test-3.ada

@@ -0,0 +1,41 @@
+with Ada.Text_IO;
+use  Ada.Text_IO;
+
+procedure Man_Or_Boy is
+
+  function Zero return Integer is ( 0);
+  function One  return Integer is ( 1);
+  function Neg  return Integer is (-1);
+
+  function A (K: Integer;
+              X1, X2, X3, X4, X5: access function return Integer) return Integer is
+    M    : Integer := K;  -- K is read-only in Ada. Here is a mutable copy of K
+    Res_A: Integer;
+    function B return Integer is
+    begin
+      M     := M - 1;
+      Res_A := A (M, B'Access, X1, X2, X3, X4);  -- set result of A
+      return Res_A;
+    end B;
+  begin
+    if M <= 0 then
+      return X4.all + X5.all;
+    else
+      declare
+        Dummy: constant Integer := B;  -- throw away
+      begin
+        return Res_A;
+      end;
+    end if;
+  end A;
+
+begin
+
+  Put_Line (Integer'Image (A (K => 10,
+                              X1 => One 'Access,
+                              X2 => Neg 'Access,
+                              X3 => Neg 'Access,
+                              X4 => One 'Access,
+                              X5 => Zero'Access)));
+
+end Man_Or_Boy;

Task/Man-or-boy-test/Elena/man-or-boy-test.elena

@@ -0,0 +1,20 @@
+#import system.
+#import extensions.
+
+#symbol A = (:k:x1:x2:x3:x4:x5)
+[
+    #var m := Integer new:k.
+    #var b := ()[ m -= 1. ^ A eval:m:this:x1:x2:x3:x4. ].
+
+    (m <= 0)
+        ? [ ^ x4 eval + x5 eval. ]
+        ! [ ^ b eval. ].
+].
+
+#symbol program =
+[
+    0 to:13 &doEach:n
+    [
+        console writeLine:(A eval:n:()[1]:()[-1]:()[-1]:()[1]:()[0]).
+    ].
+].

Task/Man-or-boy-test/Go/man-or-boy-test-2.go

@@ -3,22 +3,22 @@ package main
 import "fmt"
 
 func A(k int, x1, x2, x3, x4, x5 func() int) (a int) {
-    var B func() int
-    B = func() (b int) {
-        k--
-        a = A(k, B, x1, x2, x3, x4)
-        b = a
-        return
-    }
-    if k <= 0 {
-        a = x4() + x5()
-    } else {
-        B()
-    }
-    return
+	var B func() int
+	B = func() (b int) {
+		k--
+		a = A(k, B, x1, x2, x3, x4)
+		b = a
+		return
+	}
+	if k <= 0 {
+		a = x4() + x5()
+	} else {
+		_ = B()
+	}
+	return
 }
 
 func main() {
-    K := func(x int) func() int { return func() int { return x } }
-    fmt.Println(A(10, K(1), K(-1), K(-1), K(1), K(0)))
+	K := func(x int) func() int { return func() int { return x } }
+	fmt.Println(A(10, K(1), K(-1), K(-1), K(1), K(0)))
 }

Task/Man-or-boy-test/Go/man-or-boy-test-3.go

@@ -0,0 +1,34 @@
+package main
+
+import "fmt"
+
+func eval(v interface{}) int {
+	switch v := v.(type) {
+	case int:
+		return v
+	case func() int:
+		return v()
+	}
+	panic("bad type")
+	return 0
+}
+
+func A(k int, x1, x2, x3, x4, x5 interface{}) (a int) {
+	var B func() int
+	B = func() (b int) {
+		k--
+		a = A(k, B, x1, x2, x3, x4)
+		b = a
+		return
+	}
+	if k <= 0 {
+		a = eval(x4) + eval(x5)
+	} else {
+		_ = B()
+	}
+	return
+}
+
+func main() {
+	fmt.Println(A(10, 1, -1, -1, 1, 0))
+}

Task/Man-or-boy-test/Go/man-or-boy-test-4.go

@@ -0,0 +1,39 @@
+package main
+
+import (
+    "fmt"
+    "math/big"
+)
+
+func A(k int) *big.Int {
+    one := big.NewInt(1)
+    c0 := big.NewInt(3)
+    c1 := big.NewInt(2)
+    c2 := big.NewInt(1)
+    c3 := big.NewInt(0)
+    for j := 5; j < k; j++ {
+        c3.Sub(c3.Add(c3, c0), one)
+        c0.Add(c0, c1)
+        c1.Add(c1, c2)
+        c2.Add(c2, c3)
+    }
+    return c0.Add(c0.Sub(c0.Sub(c0, c1), c2), c3)
+}
+
+func p(k int) {
+    fmt.Printf("A(%d) = ", k)
+    if s := A(k).String(); len(s) < 60 {
+        fmt.Println(s)
+    } else {
+        fmt.Printf("%s...%s (%d digits)\n",
+            s[:6], s[len(s)-5:], len(s)-1)
+    }
+}
+
+func main() {
+    p(10)
+    p(30)
+    p(500)
+    p(10000)
+    p(1e6)
+}

Task/Man-or-boy-test/REXX/man-or-boy-test.rexx

@@ -1,16 +1,17 @@
-/*REXX program performs the "man or boy" test as far as possible for N. */
-     do n=0                            /*increment  N  from  0  forever.*/
-     say 'n='n   a(N,x1,x2,x3,x4,x5)   /*display the result to the term.*/
-     end  /*n*/                        /* [↑]  do until something breaks*/
-exit                                   /*stick a fork in it, we're done.*/
-/*──────────────────────────────────A subroutine────────────────────────*/
-a:   procedure; parse arg k,x1,x2,x3,x4,x5
-     if k<=0  then return f(x4)+f(x5)
+/*REXX program performs the  "man or boy"  test as far as possible for  N.              */
+     do n=0                                      /*increment  N  from  zero  forever.   */
+     say 'n='n   a(N,x1,x2,x3,x4,x5)             /*display the result to the terminal.  */
+     end  /*n*/                                  /* [↑]  do until something breaks.     */
+exit                                             /*stick a fork in it,  we're all done. */
+/*──────────────────────────────────────────────────────────────────────────────────────*/
+a:   procedure; parse arg k, x1, x2, x3, x4, x5
+     if k<=0  then return f(x4) + f(x5)
               else return f(b)
-/*──────────────────────────────────one─liner subroutines───────────────*/
-b:   k=k-1;                            return a(k,b,x1,x2,x3,x4)
-f:   interpret  'v='  arg(1)"()";      return v
-x1:  procedure; return  1
-x2:  procedure; return -1
-x3:  procedure; return -1
-x4:  procedure; return  1
+/*──────────────────────────────────────────────────────────────────────────────────────*/
+b:   k=k-1;                            return  a(k, b, x1, x2, x3, x4)
+f:   interpret  'v='  arg(1)"()";      return  v
+x1:  procedure;                        return  1
+x2:  procedure;                        return -1
+x3:  procedure;                        return -1
+x4:  procedure;                        return  1
+x5:  procedure;                        return  0

Task/Man-or-boy-test/TXR/man-or-boy-test-1.txr

@@ -0,0 +1,7 @@
+(defun A (k x1 x2 x3 x4 x5)
+  (labels ((B ()
+             (dec k)
+             [A k B x1 x2 x3 x4]))
+    (if (<= k 0) (+ [x4] [x5]) (B))))
+
+(prinl (A 10 (ret 1) (ret -1) (ret -1) (ret 1) (ret 0)))

Task/Man-or-boy-test/TXR/man-or-boy-test-2.txr

@@ -0,0 +1,10 @@
+(defun-cbn A (k x1 x2 x3 x4 x5)
+  (let ((k k))
+    (labels-cbn (B ()
+                  (dec k)
+                  (set B (set A (A k (B) x1 x2 x3 x4))))
+      (if (<= k 0)
+        (set A (+ x4 x5))
+        (B))))) ;; value of (B) correctly discarded here!
+
+(prinl (A 10 1 -1 -1 1 0))

Task/Man-or-boy-test/TXR/man-or-boy-test-3.txr

@@ -0,0 +1,68 @@
+(defstruct (cbn-thunk get set) nil get set)
+
+(defmacro make-cbn-val (place)
+  (with-gensyms (nv tmp)
+    (cond
+      ((constantp place)
+        ^(let ((,tmp ,place))
+           (new cbn-thunk
+             get (lambda () ,tmp)
+             set (lambda (,nv) (set ,tmp ,nv)))))
+      ((bindable place)
+        ^(new cbn-thunk
+           get (lambda () ,place)
+           set (lambda (,nv) (set ,place ,nv))))
+      (t
+        ^(new cbn-thunk
+           get (lambda () ,place)
+           set (lambda (ign) (error "cannot set ~s" ',place)))))))
+
+(defun cbn-val (cbs)
+  (call cbs.get))
+
+(defun set-cbn-val (cbs nv)
+  (call cbs.set nv))
+
+(defplace (cbn-val thunk) body
+  (getter setter
+    (with-gensyms (thunk-tmp)
+      ^(rlet ((,thunk-tmp ,thunk))
+         (macrolet ((,getter () ^(cbn-val ,',thunk-tmp))
+                    (,setter (val) ^(set-cbn-val ,',thunk-tmp ,val)))
+       ,body)))))
+
+(defun make-cbn-fun (sym args . body)
+  (let ((gens (mapcar (ret (gensym)) args)))
+    ^(,sym ,gens
+       (symacrolet ,[mapcar (ret ^(,@1 (cbn-val ,@2))) args gens]
+         ,*body))))
+
+(defmacro cbn (fun . args)
+  ^(call (fun ,fun) ,*[mapcar (ret ^(make-cbn-val ,@1)) args]))
+
+(defmacro defun-cbn (name (. args) . body)
+  (with-gensyms (hidden-fun)
+    ^(progn
+       (defun ,hidden-fun ())
+       (defmacro ,name (. args) ^(cbn ,',hidden-fun ,*args))
+       (set (symbol-function ',hidden-fun)
+            ,(make-cbn-fun 'lambda args
+                           ^(block ,name (let ((,name)) ,*body ,name)))))))
+
+(defmacro labels-cbn ((name (. args) . lbody) . body)
+  (with-gensyms (hidden-fun)
+    ^(macrolet ((,name (. args) ^(cbn ,',hidden-fun ,*args)))
+       (labels (,(make-cbn-fun hidden-fun args
+                               ^(block ,name (let ((,name)) ,*lbody ,name))))
+         ,*body))))
+
+(defun-cbn A (k x1 x2 x3 x4 x5)
+  (let ((k k))
+    (labels-cbn (B ()
+                  (dec k)
+                  (set B (set A (A k (B) x1 x2 x3 x4))))
+      (if (<= k 0)
+        (set A (+ x4 x5))
+        (B))))) ;; value of (B) correctly discarded here!
+
+(prinl (A 10 1 -1 -1 1 0))