Man or boy test: Difference between revisions

From Rosetta Code
Content added Content deleted
(Minor simplification)
(Support the zeroth term)
Line 440: Line 440:
<lang bbcbasic> HIMEM = PAGE + 10000000
<lang bbcbasic> HIMEM = PAGE + 10000000
PRINT FNA(10, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), 0)
PRINT FNA(10, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
PRINT FNA(11, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), 0)
PRINT FNA(11, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
PRINT FNA(12, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), 0)
PRINT FNA(12, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
PRINT FNA(13, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), 0)
PRINT FNA(13, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
PRINT FNA(14, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), 0)
PRINT FNA(14, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
PRINT FNA(15, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), 0)
PRINT FNA(15, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
END
END
Line 463: Line 463:
= FNA(b.k%, b{}, b.x1%, b.x2%, b.x3%, b.x4%)
= FNA(b.k%, b{}, b.x1%, b.x2%, b.x3%, b.x4%)
DEF FN0(s%) = 0
DEF FN1(s%) = 1
DEF FN1(s%) = 1
DEF FN_1(s%) = -1</lang>
DEF FN_1(s%) = -1</lang>

Revision as of 08:04, 18 May 2012

This page uses content from Wikipedia. The original article was at Man or boy test. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU FDL. (See links for details on variance)
Task
Man or boy test
You are encouraged to solve this task according to the task description, using any language you may know.
This task has been flagged for clarification. Code on this page in its current state may be flagged incorrect once this task has been clarified. See this page's Talk page for discussion.

Background: The man or boy test was proposed by computer scientist Donald Knuth as a means of evaluating implementations of the 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.

I have written the following simple routine, which may separate the 'man-compilers' from the 'boy-compilers'
— Donald Knuth

Task: Imitate Knuth's example in Algol 60 in another language, as far as possible.

Details: Local variables of routines are often kept in activation records (also call frames). In many languages, these records are kept on a call stack. In Algol (and e.g. in Smalltalk), they are allocated on a heap instead. Hence it is possible to pass references to routines that still can use and update variables from their call environment, even if the routine where those variables are declared already returned. This difference in implementations is sometimes called the Funarg Problem.

In Knuth's example, each call to A allocates an activation record for the variable A. When B is called from A, any access to k now refers to this activation record. Now B in turn calls A, but passes itself as an argument. This argument remains bound to the activation record. This call to A also "shifts" the variables xi by one place, so eventually the argument B (still bound to its particular activation record) will appear as x4 or x5 in a call to A. If this happens when the expression x4 + x5 is evaluated, then this will again call B, which in turn will update k in the activation record it was originally bound to. As this activation record is shared with other instances of calls to A and B, it will influence the whole computation.

So all the example does is to set up a convoluted calling structure, where updates to k can influence the behavior in completely different parts of the call tree.

Knuth used this to test the correctness of the compiler, but one can of course also use it to test that other languages can emulate the Algol behavior correctly. If the handling of activation records is correct, the computed value will be −67.

Performance and Memory: Man or Boy is intense and can be pushed to challenge any machine. Memory not CPU time is the constraining resource as the recursion creates a proliferation activation records which will quickly exhaust memory and present itself through a stack error. Each language may have ways of adjusting the amount of memory or increasing the recursion depth. Optionally, show how you would make such adjustments.

The table below shows the result, call depths, and total calls for a range of k:

k 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
A 1 0 -2 0 1 0 1 -1 -10 -30 -67 -138 -291 -642 -1,446 -3,250 -7,244 -16,065 -35,601 -78,985 -175,416 -389,695 -865,609 -1,922,362 -4,268,854 -9,479,595 -21,051,458 -46,750,171 -103,821,058 -230,560,902 -512,016,658
A called 1 2 3 4 8 18 38 80 167 347 722 1,509 3,168 6,673 14,091 29,825 63,287 134,652 287,264 614,442 1,317,533 2,831,900 6,100,852 13,172,239              
A depth 1 2 3 4 8 16 32 64 128 256 512 1,024 2,048 4,096 8,192 16,384 32,768 65,536 131,072 262,144 524,288 1,048,576 2,097,152 4,194,304              
B called 0 1 2 3 7 17 37 79 166 346 721 1,508 3,167 6,672 14,090 29,824 63,286 134,651 287,263 614,441 1,317,532 2,831,899 6,100,851 13,172,238              
B depth 0 1 2 3 7 15 31 63 127 255 511 1,023 2,047 4,095 8,191 16,383 32,767 65,535 131,071 262,143 524,287 1,048,575 2,097,151 4,194,303              

Ada

<lang ada>with Ada.Text_IO; use Ada.Text_IO;

procedure Man_Or_Boy is 

  function Zero return Integer is begin return  0; end Zero;
  function One return Integer  is begin return  1; end One;
  function Neg return Integer  is begin return -1; end Neg;

  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
     function B return Integer is
     begin
        M := M - 1;
        return A (M, B'Access, X1, X2, X3, X4);
     end B;
  begin
     if M <= 0 then
        return X4.all + X5.all;
     else
        return B;
     end if;
  end A;

begin 

  Put_Line
  (  Integer'Image
      (  A
         (  10,
            One'Access, -- Returns  1
            Neg'Access, -- Returns -1
            Neg'Access, -- Returns -1
            One'Access, -- Returns  1
            Zero'Access -- Returns  0
  )  )  );

end Man_Or_Boy;</lang> Sample output: 

 -67

Aime

<lang aime>integer F(list l) { 

   return l_q_integer(l, 1);

}

integer (*type(integer (*f) (list))) (list) { 

   return f;

}

integer eval(list l) { 

   return type(l_query(l, 0))(l);

}

integer A(list);

integer B(list l) { 

   integer x;
   list a;

   x = l_q_integer(l, 1);
   x -= 1;
   l_r_integer(l, 1, x);

   l_append(a, B);
   l_append(a, x);
   l_l_list(a, -1, l);
   l_l_list(a, -1, l_query(l, -5));
   l_l_list(a, -1, l_query(l, -4));
   l_l_list(a, -1, l_query(l, -3));
   l_l_list(a, -1, l_query(l, -2));

   return A(a);

}

integer A(list l) { 

   integer x;

   if (l_q_integer(l, 1) < 1) {

x = eval(l_q_list(l, -2)) + eval(l_q_list(l, -1)); 

   } else {

x = B(l); 

   }

   return x;

}

integer main(void) { 

   list a, f1, f0, fn1;

   l_append(f1, F);
   l_append(f1, 1);

   l_append(f0, F);
   l_append(f0, 0);

   l_append(fn1, F);
   l_append(fn1, -1);

   l_append(a, B);
   l_append(a, 10);
   l_l_list(a, -1, f1);
   l_l_list(a, -1, fn1);
   l_l_list(a, -1, fn1);
   l_l_list(a, -1, f1);
   l_l_list(a, -1, f0);

   o_integer(A(a));
   o_byte('\n');

   return 0;

}</lang> Output: 

 -67

ALGOL 60 - Knuth's example

begin
  real procedure A (k, x1, x2, x3, x4, x5);
  value k; integer k;
  begin
    real procedure B;
    begin k:= k - 1;
          B:= A := A (k, B, x1, x2, x3, x4);
    end;
    if k <= 0 then A:= x4 + x5 else B;
  end;
  outreal (A (10, 1, -1, -1, 1, 0));
end;

This creates a tree of B call frames that refer to each other and to the containing A call frames, each of which has its own copy of k that changes every time the associated B is called. Trying to work it through on paper is probably fruitless, but the correct answer is −67, despite the fact that in the original paper Knuth postulated it to be −121.

Note that Knuth's code states: 

    if k <= 0 then A:= x4 + x5 else B;

which actually discards the result value from the call to B. Most of the translated examples below are equivalent to: 

    A := (if k <= 0 then x4 + x5 else B);

and are therefore strictly incorrect, although in a correct 'man' compiler they do produce the expected result, because Knuth's version has already assigned to the return variable for A from within B, and it is in fact that assignment which is the true return value of the function: 

          B:= A := A (k, B, x1, x2, x3, x4);

It is most likely that this was a deliberate attempt by Knuth to find yet another way to break 'boy' compilers, rather than merely being sloppy code.

ALGOL 68

Translation of: ALGOL 60
Works with: ALGOL 68 version Revision 1 - no extensions to language used
Works with: ALGOL 68G version Any - tested with release 1.18.0-9h.tiny

Charles H. Lindsey implemented this man boy test in ALGOL 68, and - as call by name is not necessary - the same algorithm can be implemented in many languages including Pascal and PL/I . <lang algol68>PROC a = (INT in k, PROC INT xl, x2, x3, x4, x5) INT:( 

 INT k := in k;
 PROC b = INT: a(k-:=1, b, xl, x2, x3, x4);
 ( k<=0 | x4 + x5 | b )

);

test:( 

printf(($gl$,a(10, INT:1, INT:-1, INT:-1, INT:1, INT:0)))

)</lang> Output: 

        -67

AppleScript

Works with: Smile

AppleScript's stack limit is around 500 frames, which is too low to run this example. It runs in the compatible Smile environment, however.

<lang applescript>on a(k, x1, x2, x3, x4, x5) script b set k to k - 1 return a(k, b, x1, x2, x3, x4) end script if k ≤ 0 then return (run x4) + (run x5) else return (run b) end if end a

on int(x) script s return x end script return s end int

a(10, int(1), int(-1), int(-1), int(1), int(0)) </lang> Output: 

-67

BBC BASIC

Works with: BBC BASIC for Windows

<lang bbcbasic> HIMEM = PAGE + 10000000 

     PRINT FNA(10, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
     PRINT FNA(11, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
     PRINT FNA(12, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
     PRINT FNA(13, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
     PRINT FNA(14, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
     PRINT FNA(15, ^FN1(), ^FN_1(), ^FN_1(), ^FN1(), ^FN0())
     END
     
     DEF FNA(k%, x1%, x2%, x3%, x4%, x5%)
     IF k% <= 0 THEN = FN(x4%)(x4%) + FN(x5%)(x5%)
     LOCAL b{}
     DIM b{fn%, k%, x1%, x2%, x3%, x4%, x5%}
     b.fn% = !^FNB()
     b.k%  = k%
     b.x1% = x1%
     b.x2% = x2%
     b.x3% = x3%
     b.x4% = x4%
     b.x5% = x5%
     DEF FNB(!(^b{}+4))
     b.k% -= 1
     = FNA(b.k%, b{}, b.x1%, b.x2%, b.x3%, b.x4%)
     
     DEF FN0(s%) = 0
     DEF FN1(s%) = 1
     DEF FN_1(s%) = -1</lang>

Output: 

       -67
      -138
      -291
      -642
     -1446
     -3250

C

Even if closures are not available in a language, their effect can be simulated. This is what happens in the following C implementation:

<lang c>/* man-or-boy.c */

  1. include <stdio.h>
  2. include <stdlib.h>

// --- thunks typedef struct arg { 

 int       (*fn)(struct arg*);
 int        *k;
 struct arg *x1, *x2, *x3, *x4, *x5;

} ARG;

// --- lambdas int f_1 (ARG* _) { return -1; } int f0 (ARG* _) { return 0; } int f1 (ARG* _) { return 1; }

// --- helper int eval(ARG* a) { return a->fn(a); }

  1. define MAKE_ARG(...) (&(ARG){__VA_ARGS__})
  2. define FUN(...) MAKE_ARG(B, &k, __VA_ARGS__)

int A(ARG*);

// --- functions int B(ARG* a) { 

 int k = *a->k -= 1;
 return A(FUN(a, a->x1, a->x2, a->x3, a->x4));

}

int A(ARG* a) { 

 return *a->k <= 0 ? eval(a->x4) + eval(a->x5) : B(a);

}

int main(int argc, char **argv) { 

 int k = argc == 2 ? strtol(argv[1], 0, 0) : 10;
 printf("%d\n", A(FUN(MAKE_ARG(f1), MAKE_ARG(f_1), MAKE_ARG(f_1),
                      MAKE_ARG(f1), MAKE_ARG(f0))));
 return 0;

}</lang>

Two gcc extensions to the C language, nested functions and block sub-expressions, can be combined to create this elegant version:

Version: gcc version 4.1.2 20070925 (Red Hat 4.1.2-27) <lang c>#include <stdio.h>

  1. define INT(body) ({ int lambda(){ body; }; lambda; })

main(){ 

 int a(int k, int xl(), int x2(), int x3(), int x4(), int x5()){
   int b(){
     return a(--k, b, xl, x2, x3, x4);
   }
   return k<=0 ? x4() + x5() : b();
 }
 printf(" %d\n",a(10, INT(return 1), INT(return -1), INT(return -1), INT(return 1), INT(return 0)));

}</lang>

C without C99 or gcc extensions:

<lang c>#include <stdio.h>

  1. include <stdlib.h>

typedef struct frame { 

 int (*fn)(struct frame*);
 union { int constant; int* k; } u;
 struct frame *x1, *x2, *x3, *x4, *x5;

} FRAME;

FRAME* Frame(FRAME* f, int* k, FRAME* x1, FRAME* x2, FRAME *x3, FRAME *x4, FRAME *x5) { 

 f->u.k = k;
 f->x1 = x1;
 f->x2 = x2;
 f->x3 = x3;
 f->x4 = x4;
 f->x5 = x5;
 return f;

}

int F(FRAME* a) { return a->u.constant; }

int eval(FRAME* a) { return a->fn(a); }

int A(FRAME*);

int B(FRAME* a) { 

 int k = (*a->u.k -= 1);
 FRAME b = { B };
 return A(Frame(&b, &k, a, a->x1, a->x2, a->x3, a->x4));

}

int A(FRAME* a) { 

 return *a->u.k <= 0 ? eval(a->x4) + eval(a->x5) : B(a);

}

int main(int argc, char** argv) { 

 int k = argc == 2 ? strtol(argv[1], 0, 0) : 10;
 FRAME a = { B }, f1 = { F, { 1 } }, f0 = { F, { 0 } }, fn1 = { F, { -1 } };

 printf("%d\n", A(Frame(&a, &k, &f1, &fn1, &fn1, &f1, &f0)));
 return 0;

}</lang>

Output: 

-67

C++

works with GCC

Uses "shared_ptr" smart pointers from Boost / TR1 to automatically deallocate objects. Since we have an object which needs to pass a pointer to itself to another function, we need to use "enable_shared_from_this".

<lang cpp>#include <iostream>

  1. include <tr1/memory>

using std::tr1::shared_ptr; using std::tr1::enable_shared_from_this;

struct Arg { 

 virtual int run() = 0;
 virtual ~Arg() { };

};

int A(int, shared_ptr<Arg>, shared_ptr<Arg>, shared_ptr<Arg>, 

     shared_ptr<Arg>, shared_ptr<Arg>);

class B : public Arg, public enable_shared_from_this { private: 

 int k;
 const shared_ptr<Arg> x1, x2, x3, x4;

public: 

 B(int _k, shared_ptr<Arg> _x1, shared_ptr<Arg> _x2, shared_ptr<Arg> _x3,
   shared_ptr<Arg> _x4)
   : k(_k), x1(_x1), x2(_x2), x3(_x3), x4(_x4) { }
 int run() {
   return A(--k, shared_from_this(), x1, x2, x3, x4);
 }

};

class Const : public Arg { private: 

 const int x;

public: 

 Const(int _x) : x(_x) { }
 int run () { return x; }

};

int A(int k, shared_ptr<Arg> x1, shared_ptr<Arg> x2, shared_ptr<Arg> x3, 

     shared_ptr<Arg> x4, shared_ptr<Arg> x5) {
 if (k <= 0)
   return x4->run() + x5->run();
 else {
   shared_ptr<Arg> b(new B(k, x1, x2, x3, x4));
   return b->run();
 }

}

int main() { 

 std::cout << A(10, shared_ptr<Arg>(new Const(1)),
                shared_ptr<Arg>(new Const(-1)),
                shared_ptr<Arg>(new Const(-1)),
                shared_ptr<Arg>(new Const(1)),
                shared_ptr<Arg>(new Const(0))) << std::endl;
 return 0;

}</lang>

Works with: C++11

uses anonymous functions. Tested with g++ version 4.5 and Visual C++ version 16 (Windows SDK 7.1):

<lang cpp>#include <functional>

  1. include <iostream>

typedef std::function<int()> F;

static int A(int k, const F &x1, const F &x2, const F &x3, const F &x4, const F &x5) { F B = [=, &k, &B] { return A(--k, B, x1, x2, x3, x4); };

return k <= 0 ? x4() + x5() : B(); }

static F L(int n) { return [n] { return n; }; }

int main() { std::cout << A(10, L(1), L(-1), L(-1), L(1), L(0)) << std::endl; return 0; }</lang>

Works with: TR1

uses TR1 without C++11.

<lang cpp>#include <tr1/functional>

  1. include <iostream>

typedef std::tr1::function<int()> F;

static int A(int k, const F &x1, const F &x2, const F &x3, const F &x4, const F &x5);

struct B_class { 

 int &k;
 const F x1, x2, x3, x4;
 B_class(int &_k, const F &_x1, const F &_x2, const F &_x3, const F &_x4) :
   k(_k), x1(_x1), x2(_x2), x3(_x3), x4(_x4) { }
 int operator()() const { return A(--k, *this, x1, x2, x3, x4); }

};

static int A(int k, const F &x1, const F &x2, const F &x3, const F &x4, const F &x5) { 

 F B = B_class(k, x1, x2, x3, x4);
 return k <= 0 ? x4() + x5() : B();

}

struct L { 

 const int n;
 L(int _n) : n(_n) { }
 int operator()() const { return n; }

};

int main() { 

 std::cout << A(10, L(1), L(-1), L(-1), L(1), L(0)) << std::endl;
 return 0;

}</lang>

C#

C# 2.0 supports anonymous methods which are used in the implementation below:

Works with: C# version 2+

<lang csharp>using System;

delegate T Func<T>();

class ManOrBoy { 

   static void Main()
   {
       Console.WriteLine(A(10, C(1), C(-1), C(-1), C(1), C(0)));
   }

   static Func<int> C(int i)
   {
       return delegate { return i; };
   }

   static int A(int k, Func<int> x1, Func<int> x2, Func<int> x3, Func<int> x4, Func<int> x5)
   {
       Func<int> b = null;
       b = delegate { k--; return A(k, b, x1, x2, x3, x4); };
       return k <= 0 ? x4() + x5() : b();
   }

} </lang>

C# 3.0 supports lambda expressions which are used in the implementation below:

Works with: C# version 3+

<lang csharp>using System;

class ManOrBoy { 

   static void Main()
   {
       Console.WriteLine(A(10, () => 1, () => -1, () => -1, () => 1, () => 0));
   }

   static int A(int k, Func<int> x1, Func<int> x2, Func<int> x3, Func<int> x4, Func<int> x5)
   {
       Func<int> b = null;
       b = () => { k--; return A(k, b, x1, x2, x3, x4); };
       return k <= 0 ? x4() + x5() : b();
   }

}</lang>

Clipper

<lang Clipper>Procedure Main() 

  Local k
  For k := 0 to 20
     ? "A(", k, ", 1, -1, -1, 1, 0) =", A(k, 1, -1, -1, 1, 0)
  Next

Return

Static Function A(k, x1, x2, x3, x4, x5) 

  Local ARetVal
  Local B := {|| --k, ARetVal := A(k, B, x1, x2, x3, x4) }
  If k <= 0
     ARetVal := Evaluate(x4) + Evaluate(x5)
  Else
     B:Eval()
  Endif

Return ARetVal

Static Function Evaluate(x) 

  Local xVal
  If ValType(x) == "B"
     xVal := x:Eval()
  Else
     xVal := x
  Endif

Return xVal</lang>


// With Clipper 5.2e compiler and standard RTLINK linker, default settings, only manages up to k=5 before a stack fault: 

EVALUATE (0)  Unrecoverable error 650: Processor stack fault

// Using Blinker v5.1 it can get up to k=7 by increasing the stack size via BLINKER PROCEDURE DEPTH 74. But that may be the limit for 16-bit Clipper; increasing the procedure depth further does not help, and eventually results in 

A (0)  Unrecoverable error 667: Eval stack fault

Harbour however is definitely a man: a 32-bit WinXP executable built with Harbour v3.1 and mingw gcc 4.6.1 manages up to k=13 with the default settings. Increasing the stack size (via the Microsoft utility "editbin /STACK:nnn", or "ulimit -s" in linux) allows it to achieve deeper levels: 

A(          0 , 1, -1, -1, 1, 0) =          1 
A(          1 , 1, -1, -1, 1, 0) =          0 
A(          2 , 1, -1, -1, 1, 0) =         -2 
A(          3 , 1, -1, -1, 1, 0) =          0 
A(          4 , 1, -1, -1, 1, 0) =          1 
A(          5 , 1, -1, -1, 1, 0) =          0 
A(          6 , 1, -1, -1, 1, 0) =          1 
A(          7 , 1, -1, -1, 1, 0) =         -1 
A(          8 , 1, -1, -1, 1, 0) =        -10 
A(          9 , 1, -1, -1, 1, 0) =        -30 
A(         10 , 1, -1, -1, 1, 0) =        -67 
A(         11 , 1, -1, -1, 1, 0) =       -138 
A(         12 , 1, -1, -1, 1, 0) =       -291 
A(         13 , 1, -1, -1, 1, 0) =       -642 
A(         14 , 1, -1, -1, 1, 0) =      -1446 
A(         15 , 1, -1, -1, 1, 0) =      -3250 
A(         16 , 1, -1, -1, 1, 0) =      -7244 
A(         17 , 1, -1, -1, 1, 0) =     -16065 
A(         18 , 1, -1, -1, 1, 0) =     -35601 
A(         19 , 1, -1, -1, 1, 0) =     -78985 
A(         20 , 1, -1, -1, 1, 0) =    -175416

Clojure

<lang lisp>(declare a)

(defn man-or-boy 

 "Man or boy test for Clojure"
 [k]
 (let [k (atom k)]
   (a k
      (fn [] 1)
      (fn [] -1)
      (fn [] -1)
      (fn [] 1)
      (fn [] 0))))

(defn a 

 [k x1 x2 x3 x4 x5]
 (let [k (atom @k)]
   (letfn [(b []
              (swap! k dec)
              (a k b x1 x2 x3 x4))]
     (if (<= @k 0)
       (+ (x4) (x5))
       (b)))))

(man-or-boy 10) </lang>

Common Lisp

<lang lisp>(defun man-or-boy (x) 

(a x (lambda () 1)
     (lambda () -1)
     (lambda () -1)
     (lambda () 1)
     (lambda () 0)))

(defun a (k x1 x2 x3 x4 x5) 

 (labels ((b ()
            (decf k)
            (a k #'b x1 x2 x3 x4)))
   (if (<= k 0)
       (+ (funcall x4) (funcall x5))
       (b))))

(man-or-boy 10)</lang>

D

Straightforward Version

<lang d>import core.stdc.stdio: printf;

int a(int k, const lazy int x1, const lazy int x2, const lazy int x3, 

     const lazy int x4, const lazy int x5) pure {
   int b() {
       k--;
       return a(k, b(), x1, x2, x3, x4);
   }
   return k <= 0 ? x4 + x5 : b();

}

void main() { 

   printf("%d\n", a(10, 1, -1, -1, 1, 0));

}</lang> The DMD compiler is a man. Increasing the maximum stack space to about 1.2 GB the DMD 2.059 compiler computes the result -9479595 for k = 25 in about 6.5 seconds on a 32 bit system (-inline -O -release -L/STACK:1300000000).

Lazy Variadic Function Version

Lazy Variadic Functions version, as quoted:

If the variadic parameter is an array of delegates with no parameters:
    void foo(int delegate()[] dgs ...);
Then each of the arguments whose type does not match that of the delegate is converted to a delegate.
    int delegate() dg;
    foo(1, 3+x, dg, cast(int delegate())null);
is the same as:
    foo( { return 1; }, { return 3+x; }, dg, null );

<lang d>import std.stdio;

int A(int k, int delegate()[] x ...) { 

   int b() {
       k--;
       return A(k, &b, x[0], x[1], x[2], x[3]);
   }

   return (k <= 0) ? x[3]() + x[4]() : b();

}

void main() { 

   writeln(A(10, 1, -1, -1, 1, 0));

}</lang>

Template Version

<lang d>import std.stdio;

int delegate() mb(T)(T mob) { // embeding function 

   int b() {
       static if (is(T == int))
           return mob;
       else
           return mob();
   }

   return &b;

}

int A(T)(int k, T x1, T x2, T x3, T x4, T x5) { 

   static if (is(T == int)) {
       return A(k, mb(x1), mb(x2), mb(x3), mb(x4), mb(x5));
   } else {
       int b() {
           k--;
           return A(k, &b, x1, x2, x3, x4);
       }
       return (k <= 0) ? x4() + x5() : b();
   }

}

void main() { 

   writeln(A(10, 1, -1, -1, 1, 0));

}</lang>

Anonymous Class Version

Similar to Java example: <lang d>import std.stdio;

interface B { 

   int run();

}

int A(int k, int x1, int x2, int x3, int x4, int x5) { 

   B mb(int a) {
       return new class() B {
           int run() {
               return a;
           }
       };
   }

   return A(k, mb(x1), mb(x2), mb(x3), mb(x4), mb(x5));

}

int A(int k, B x1, B x2, B x3, B x4, B x5) { 

   if (k <= 0) {
       return x4.run() + x5.run();
   } else {
       return (new class() B {
           int m;

           this() {
               this.m = k;
           }

           int run() {
               m--;
               return A(m, this, x1, x2, x3, x4);
           }
       }).run();
   }

}

void main() { 

   writeln(A(10, 1, -1, -1, 1, 0));

}</lang>

Delphi

The latest editions of Delphi support anonymous methods, providing a way to implement call by name semantics.

<lang delphi>type 

 TFunc<T> = reference to function: T;

function C(x: Integer): TFunc<Integer>; begin 

 Result := function: Integer
 begin
   Result := x;
 end;

end;

function A(k: Integer; x1, x2, x3, x4, x5: TFunc<Integer>): Integer; var 

 b: TFunc<Integer>;

begin 

 b := function: Integer
 begin
   Dec(k);
   Result := A(k, b, x1, x2, x3, x4);
 end;
 if k <= 0 then
   Result := x4 + x5
 else
   Result := b;

end;

begin 

 Writeln(A(10, C(1), C(-1), C(-1), C(1), C(0))); // -67 output

end.</lang>

E

Provided that it is marked in the caller and callee, E can perfectly emulate the requested call-by-name behavior by passing slots instead of values:

<lang e>def a(var k, &x1, &x2, &x3, &x4, &x5) { 

   def bS; def &b := bS
   bind bS {
       to get() {
           k -= 1
           return a(k, &b, &x1, &x2, &x3, &x4)        
       }
   }
   return if (k <= 0) { x4 + x5 } else { b }

}

def p := 1 def n := -1 def z := 0 println(a(10, &p, &n, &n, &p, &z))</lang>

Here each of the "x" parameters is effectively call-by-name. b is bound to a custom slot definition.

Erlang

Erlang variables cannot be changed after binding, so k is decremented by sending a message to a process. 

kloop(K) ->
    receive
        {decr,Pid} -> Pid ! K-1, kloop(K-1);
        _          -> ok
    end.
 
 
a(K, X1, X2, X3, X4, X5) ->
    Kproc = spawn(fun() -> kloop(K) end),
    B = fun (B) -> 
                Kproc ! {decr, self()},
                receive Kdecr ->
                        a(Kdecr, fun() -> B(B) end, X1, X2, X3, X4)
                end
        end,
    if
        K =< 0  -> Kproc ! X4() + X5();
        true    -> Kproc ! B(B)
    end.
 
 
manorboy(N) ->                
     a(N, fun() -> 1 end, fun() -> -1 end, fun() -> -1 end, fun() -> 1 end, fun() -> 0 end ).

Fantom

Fantom has closures, so:

<lang Fantom> class ManOrBoy { 

 Void main()
 {
   echo(A(10, |->Int|{1}, |->Int|{-1}, |->Int|{-1}, |->Int|{1}, |->Int|{0}));
 }

 static Int A(Int k, |->Int| x1, |->Int| x2, |->Int| x3, |->Int| x4, |->Int| x5)
 {
   |->Int|? b
   b = |->Int| { k--; return A(k, b, x1, x2, x3, x4) }
   return k <= 0 ? x4() + x5() : b()
 }

} </lang>

yields 

  -67

Fortran

Fortran 2008 (uses an internal procedure as function argument). Tested with g95 and gfortran 4.6. <lang Fortran>module man_or_boy

implicit none

contains 

 recursive integer function A(k,x1,x2,x3,x4,x5) result(res)
   integer, intent(in) :: k
   interface
     recursive integer function x1()
     end function
     recursive integer function x2()
     end function
     recursive integer function x3()
     end function
     recursive integer function x4()
     end function
     recursive integer function x5()
     end function
   end interface
   integer :: m
   if ( k <= 0 ) then
     res = x4()+x5()
   else
     m = k
     res = B()
   end if
 
 contains
 
   recursive integer function B() result(res)    
     m = m-1
     res = A(m,B,x1,x2,x3,x4)
   end function B
 
 end function A



 recursive integer function one() result(res)
   res = 1
 end function

 recursive integer function minus_one() result(res)
   res = -1
 end function

 recursive integer function zero() result(res)
   res = 0
 end function

end module man_or_boy

program test 

 use man_or_boy
 write (*,*) A(10,one,minus_one,minus_one,one,zero)

end program test</lang>

Go

<lang go>package main import "fmt"

func a(k int, x1, x2, x3, x4, x5 func() int) int { var b func() int b = func() int { k-- return a(k, b, x1, x2, x3, x4) } if k <= 0 { return x4() + x5() } return b() }

func main() { x := func(i int) func() int { return func() int { return i } } fmt.Println(a(10, x(1), x(-1), x(-1), x(1), x(0))) }</lang>

Another version that uses named result parameters the way the original Algol uses the function name. This includes B setting the result of its enclosing A. <lang go>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

}

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)))

}</lang>

Haskell

Haskell is a pure language, so the impure effects of updating k must be wrapped in the IO or state monad:

<lang haskell> import Control.Monad 

import Data.IORef

a k x1 x2 x3 x4 x5 = do r <- newIORef k
                        let b = do k <- pred !r
                                   a k b x1 x2 x3 x4
                        if k <= 0 then liftM2 (+) x4 x5 else b
    where f !r = modifyIORef r f >> readIORef r

main = do n <- a 10 #1 #(-1) #(-1) #1 #0
          print n
    where (#) f = f . return</lang>

On a Core 2 Duo 2.0 GHz using GHC 7.4.1 this program can compute k = 26 in 31 s and 4.3 GiB.

Icon and Unicon

There are a few challenges to implementing MoB in Icon/Unicon.

  • There are no nested procedures and non-local variables that go with them
  • There is no selectable call by value .vs. call by name/reference. Knowledge of the implicit mutable/immutable types is needed.
  • Procedure calls can't be deferred transparently but can be deferred through co-expressions
  • Co-expressions aren't enough as they trap local copies of variables which follow Icon rules for mutability/immutability

The initial solution below involved the use of co-expressions which seemed a natural tool to solve MoB. It turns out that co-expressions aren't necessary to solve this task. Co-expressions are very powerful and MoB really doesn't exercise their full capability. There is a lighter weight solution and also a cheat solution which is a further simplification. The light weight version exploits that procedures are a data type and can be passed around and assigned. This allows us to defer calling 'B' which is just what is required. The change introduces a new record definition 'defercall' and changes only two lines of the original solution in 'eval' and 'B'. The cheat would be to have 'eval' know that it always called 'B'.

MoB is intense and can be pushed to challenge any machine. If you run this and the program hangs up or fails with an inadequate space for static allocation error, you may need to tweak the way Icon/Unicon allocates memory. This is controlled through the environment variables COEXPSIZE, MSTKSIZE, BLKSIZE (see Icon and Unicon Environment Variables).

Notes:

  • The co-expression version will require adjustment to COEXPRSIZE, and possibly BLKSIZE and MSTKSIZE.
    • Mob 13 ran on a machine with 4GB RAM running Unicon Win32 using COEXPSIZE=71000; BLKSIZE=2000000; and MSTKSIZE=1000000.
    • Mob 15 ran on on a 64-bit linux box with 16GB RAM with COEXPSIZE to 200000 (and everything else defaulting).
  • The non-co-expression version required adjustment to BLKSIZE and MSTKSIZE.
    • Mob 21 ran on the same 4GB machine with BLKSIZE=10000000; and MSTKSIZE=70000000
    • Mob 23 ran on the same 4GB machine with BLKSIZE=20000000; and MSTKSIZE=300000000

The co-expression version. <lang Icon>record mutable(value) # we need mutable integers 

                                                             # ... be obvious when we break normal scope rules

procedure main(arglist) # supply the initial k value k := integer(arglist[1])|10 # .. or default to 10=default write("Man or Boy = ", A( k, 1, -1, -1, 1, 0 ) ) end

procedure eval(ref) # evaluator to distinguish between a simple value and a code reference return if type(ref) == "co-expression" then @ref else ref end

procedure A(k,x1,x2,x3,x4,x5) # Knuth's A k := mutable(k) # make k mutable for B return if k.value <= 0 then # -> boy compilers may recurse and die here 

  eval(x4) + eval(x5)                                        # the crux of separating man .v. boy compilers

else # -> boy compilers can run into trouble at k=5+ 

  B(k,x1,x2,x3,x4,x5)

end

procedure B(k,x1,x2,x3,x4,x5) # Knuth's B k.value -:= 1 # diddle A's copy of k return A(k.value, create |B(k,x1,x2,x3,x4,x5),x1,x2,x3,x4) # call A with a new k and 5 x's end</lang>

Below are the code changes for the non-co-expression version. A new record type is introduced and the two return expressions are changed slightly.

<lang Icon>record defercall(proc,arglist) # light weight alternative to co-expr for MoB

procedure eval(ref) # evaluator to distinguish between a simple value and a code reference return if type(ref) == "defercall" then ref.proc!ref.arglist else ref end

procedure B(k,x1,x2,x3,x4,x5) # Knuth's B k.value -:= 1 # diddle A's copy of k return A(k.value, defercall(B,[k,x1,x2,x3,x4,x5]),x1,x2,x3,x4)# call A with a new k and 5 x's end</lang>

J

Given

<lang J>A=:4 :0 

 L=.cocreate  NB. L is context where names are defined.
 k__L=:x
 '`x1__L x2__L x3__L x4__L x5__L'=:y
 if.k__L<:0 do.a__L=:(x4__L + x5__L)f. else. L B  end.
 (coerase L)]]]a__L

)

B=:4 :0 

 L=.x
 k__L=:k__L-1
 a__L=:k__L A L&B`(x1__L f.)`(x2__L f.)`(x3__L f.)`(x4__L f.)

)</lang>


<lang J> 10 A 1:`_1:`_1:`1:`0: _67</lang>

Java

We use anonymous classes to represent closures.

<lang java>public class ManOrBoy { 

   interface Arg {
       public int run();
   }

   public static int A(final int k, final Arg x1, final Arg x2,
                         final Arg x3, final Arg x4, final Arg x5) {
       if (k <= 0)
           return x4.run() + x5.run();
       return new Arg() {
           int m = k;
           public int run() {
               m--;
               return A(m, this, x1, x2, x3, x4);
           }
       }.run();
   }
   public static Arg C(final int i) {
       return new Arg() {
           public int run() { return i; }
       };
   }

   public static void main(String[] args) {
       System.out.println(A(10, C(1), C(-1), C(-1), C(1), C(0)));
   }

}</lang>

JavaScript

JavaScript 1.8+ <lang javascript>function A(k, x1, x2, x3, x4, x5) { 

   function B() A(--k, B, x1, x2, x3, x4);
   return k <= 0 ? x4() + x5() : B();

}

function K(n) function() n;

alert(A(10, K(1), K(-1), K(-1), K(1), K(0)));</lang>

Lua

<lang lua>function a(k,x1,x2,x3,x4,x5) 

 local function b()
   k = k - 1
   return a(k,b,x1,x2,x3,x4)
 end
  if k <= 0 then return x4() + x5() else return b() end

end

function K(n) 

 return function()
   return n
 end

end

print(a(10, K(1), K(-1), K(-1), K(1), K(0)))</lang>

Mathematica

This Mathematica code was derived from the Ruby example appearing below. 

$RecursionLimit = 1665; (* anything less fails for k0 = 10 *)

a[k0_, x1_, x2_, x3_, x4_, x5_] := Module[{k, b },
  k = k0;
  b = (k--; a[k, b, x1, x2, x3, x4]) &;
  If[k <= 0, x4[] + x5[], b[]]]

a[10, 1 &, -1 &, -1 &, 1 &, 0 &] (* => -67 *)

Modula-3

<lang modula3>MODULE Main; IMPORT IO;

TYPE Function = PROCEDURE ():INTEGER;

PROCEDURE A(k: INTEGER; x1, x2, x3, x4, x5: Function): INTEGER = 

 PROCEDURE B(): INTEGER =
 BEGIN
   DEC(k);
   RETURN A(k, B, x1, x2, x3, x4);
 END B;

BEGIN 

 IF k <= 0 THEN
   RETURN x4() + x5();
 ELSE
   RETURN B();
 END;

END A;

PROCEDURE F0(): INTEGER = BEGIN RETURN 0; END F0; PROCEDURE F1(): INTEGER = BEGIN RETURN 1; END F1; PROCEDURE Fn1(): INTEGER = BEGIN RETURN -1; END Fn1;

BEGIN 

 IO.PutInt(A(10, F1, Fn1, Fn1, F1, F0));
 IO.Put("\n");

END Main.</lang>

Objective-C

Works with: Cocoa version Mac OS X 10.6+

<lang objc>#import <Foundation/Foundation.h>

typedef NSInteger (^IntegerBlock)();

NSInteger A (NSInteger kParam, IntegerBlock x1, IntegerBlock x2, IntegerBlock x3, IntegerBlock x4, IntegerBlock x5) { 

   __block NSInteger k = kParam;
   __block IntegerBlock B; // due to a GCC bug, we have to initialize on a separate line
   B = ^ {
       return A(--k, B, x1, x2, x3, x4);
   };
   return k <= 0 ? x4() + x5() : B();

}

IntegerBlock K (NSInteger n) { 

   IntegerBlock result = ^{return n;};
   return [[result copy] autorelease];

}

int main (int argc, const char * argv[]) { 

   NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];
   NSInteger result = A(10, K(1), K(-1), K(-1), K(1), K(0));
   NSLog(@"%d\n", result);
   [pool drain];
   return 0;

}</lang>

without Blocks: <lang objc>@protocol IntegerFun <NSObject> -(NSInteger)call; @end

NSInteger A (NSInteger kParam, id<IntegerFun> x1, id<IntegerFun> x2, id<IntegerFun> x3, id<IntegerFun> x4, id<IntegerFun> x5);

@interface B_Class : NSObject <IntegerFun> { 

 NSInteger *k;
 id<IntegerFun> x1, x2, x3, x4;

} -(id)initWithK:(NSInteger *)k x1:(id<IntegerFun>)x1 x2:(id<IntegerFun>)x2 x3:(id<IntegerFun>)x3 x4:(id<IntegerFun>)x4; @end

@implementation B_Class -(id)initWithK:(NSInteger *)_k x1:(id<IntegerFun>)_x1 x2:(id<IntegerFun>)_x2 x3:(id<IntegerFun>)_x3 x4:(id<IntegerFun>)_x4 { 

 if ((self = [super init])) {
   k = _k;
   x1 = [_x1 retain];
   x2 = [_x2 retain];
   x3 = [_x3 retain];
   x4 = [_x4 retain];
 }
 return self;

} -(void)dealloc { 

 [x1 release];
 [x2 release];
 [x3 release];
 [x4 release];
 [super dealloc];

} -(NSInteger)call { 

 return A(--*k, self, x1, x2, x3, x4);

} @end

NSInteger A (NSInteger k, id<IntegerFun> x1, id<IntegerFun> x2, id<IntegerFun> x3, id<IntegerFun> x4, id<IntegerFun> x5) { 

 id<IntegerFun> B = [[[B_Class alloc] initWithK:&k x1:x1 x2:x2 x3:x3 x4:x4] autorelease];
 return k <= 0 ? [x4 call] + [x5 call] : [B call];

}

@interface K : NSObject <IntegerFun> { 

 NSInteger n;

} -(id)initWithN:(NSInteger)n; @end

@implementation K -(id)initWithN:(NSInteger)_n { 

 if ((self = [super init])) {
   n = _n;
 }
 return self;

} -(NSInteger)call { 

 return n;

} @end

int main(int argc, const char *argv[]) { 

 NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];
 
 NSInteger result = A(10,
                      [[[K alloc] initWithN:1] autorelease],
                      [[[K alloc] initWithN:-1] autorelease],
                      [[[K alloc] initWithN:-1] autorelease],
                      [[[K alloc] initWithN:1] autorelease],
                      [[[K alloc] initWithN:0] autorelease]);
 NSLog(@"%ld\n", result);
 
 [pool release];
 return 0;

}</lang>

OCaml

OCaml variables are not mutable, so "k" is wrapped in a mutable object, which we access through a reference type called "ref".

<lang ocaml>let rec a k x1 x2 x3 x4 x5 = 

 if k <= 0 then
   x4 () + x5 ()
 else
   let m = ref k in
   let rec b () =
     decr m;
     a !m b x1 x2 x3 x4
   in
   b ()

let () = 

 Printf.printf "%d\n" (a 10 (fun () -> 1) (fun () -> -1) (fun () -> -1) (fun () -> 1) (fun () -> 0))</lang>

Oz

We emulate the ALGOL60 example as closely as possible. Like most of the examples, we use functions to emulate call-by-name.

Oz variables are immutable, so we use a mutable reference ("cell") for K. The ALGOL example uses call-by-value for K. Oz uses call-by-reference, therefore we copy K explicitly when we call A recursively.

We use explicit "return variables" to emulate the strange behaviour of the ALGOL B procedure which assigns a value to A's return value.

<lang oz>declare 

 fun {A K X1 X2 X3 X4 X5}
    ReturnA = {NewCell undefined}
    fun {B}
       ReturnB = {NewCell undefined}
    in
       K := @K - 1
       ReturnA := {A {NewCell @K} B X1 X2 X3 X4}
       ReturnB := @ReturnA
       @ReturnB
    end
 in
    if @K =< 0 then ReturnA := {X4} + {X5} else _ = {B} end
    @ReturnA
 end

 fun {C V}
    fun {$} V end
 end

in 

 {Show {A {NewCell 10} {C 1} {C ~1} {C ~1} {C 1} {C 0}}}</lang>

Perl

<lang perl>sub A { 

   my ($k, $x1, $x2, $x3, $x4, $x5) = @_;
   my($B);
   $B = sub { A(--$k, $B, $x1, $x2, $x3, $x4) };
   $k <= 0 ? &$x4 + &$x5 : &$B;

}

print A(10, sub{1}, sub {-1}, sub{-1}, sub{1}, sub{0} ), "\n";</lang>

Perl 6

Works with: niecza version 2012-01

<lang perl6>sub A($k is copy, &x1, &x2, &x3, &x4, &x5) { 

   sub B { A(--$k, &B, &x1, &x2, &x3, &x4) }
   if $k <= 0 { x4() + x5() } else { B() }

};

say A(10, {1}, {-1}, {-1}, {1}, {0});</lang> Output: 

-67

PHP

PHP 5.3 has closures, so: <lang php><?php function A($k,$x1,$x2,$x3,$x4,$x5) { 

   $b = function () use (&$b,&$k,$x1,$x2,$x3,$x4) {
       return A(--$k,$b,$x1,$x2,$x3,$x4);
   };
   return $k <= 0 ? $x4() + $x5() : $b();

}

echo A(10, function () { return 1; }, 

          function () { return -1; },
          function () { return -1; },
          function () { return  1; }, 
          function () { return  0; }) . "\n";

?></lang>

PicoLisp

As PicoLisp uses exclusively shallow dynamic binding, stack frames have to be explicitly constructed. <lang PicoLisp>(de a (K X1 X2 X3 X4 X5) 

  (let (@K (cons K)  B (cons))  # Explicit frame
     (set B
        (curry (@K B X1 X2 X3 X4) ()
           (a (dec @K) (car B) X1 X2 X3 X4) ) )
     (if (gt0 (car @K)) ((car B)) (+ (X4) (X5))) ) )

(a 10 '(() 1) '(() -1) '(() -1) '(() 1) '(() 0))</lang> Output: 

-> -67

PL/I

morb: proc options (main) reorder;
 dcl sysprint file;

 put skip list(a((10), lambda1, lambdam1, lambdam1, lambda0, lambda0));

 a: proc(k, x1, x2, x3, x4, x5) returns(fixed bin (31)) recursive;
   dcl k                    fixed bin (31);
   dcl (x1, x2, x3, x4, x5) entry returns(fixed bin (31));

   b: proc returns(fixed bin(31)) recursive;
     k = k - 1;
     return(a((k), b, x1, x2, x3, x4));
   end b;

   if k <= 0 then
     return(x4 + x5); 
   else
     return(b);
 end a;

 lambdam1: proc returns(fixed bin (31)); return(-1); end lambdam1;
 lambda0:  proc returns(fixed bin (31)); return(1);  end lambda0;
 lambda1:  proc returns(fixed bin (31)); return(1);  end lambda1;
end morb;

The above PL/I code has been tested on OS PL/I V2.3.0, Enterprise PL/I V3R9M0 and PL/I for Windows V8.0. The limit for OS PL/I on a z/OS machine with 4Gb seems to be A=15, the limit for Enterprise PL/I on the same machine seems to be A=23, and the limit for PL/I for Windows on a 16Gb system seems to be A=26.

Pop11

define A(k, x1, x2, x3, x4, x5);
    define B();
        k - 1 -> k;
        A(k, B, x1, x2, x3, x4)
    enddefine;
    if k <= 0 then
        x4() + x5()
    else
        B()
    endif
enddefine;

define one(); 1 enddefine;
define minus_one(); -1 enddefine;
define zero(); 0 enddefine;
A(10, one, minus_one, minus_one, one, zero) =>

Python

Works with: Python version 2.5

<lang python>#!/usr/bin/env python import sys sys.setrecursionlimit(1025)

def a(in_k, x1, x2, x3, x4, x5): 

   k = [in_k]
   def b():
       k[0] -= 1
       return a(k[0], b, x1, x2, x3, x4)
   return x4() + x5() if k[0] <= 0 else b()

x = lambda i: lambda: i print(a(10, x(1), x(-1), x(-1), x(1), x(0))) </lang> A better-looking alternative to using lists as storage are function attributes: <lang python>#!/usr/bin/env python import sys sys.setrecursionlimit(1025)

def a(k, x1, x2, x3, x4, x5): 

   def b():
       b.k -= 1
       return a(b.k, b, x1, x2, x3, x4)
   b.k = k
   return x4() + x5() if b.k <= 0 else b()

x = lambda i: lambda: i print(a(10, x(1), x(-1), x(-1), x(1), x(0))) </lang>

Output: 

-67

Py3k

Works with: Python version 3.0

<lang python>#!/usr/bin/env python import sys sys.setrecursionlimit(1025)

def A(k, x1, x2, x3, x4, x5): 

   def B():
       nonlocal k
       k -= 1
       return A(k, B, x1, x2, x3, x4)
   return x4() + x5() if k <= 0 else B()

print(A(10, lambda: 1, lambda: -1, lambda: -1, lambda: 1, lambda: 0))</lang>

R

Like many implementations this uses lambda wrappers around the numeric arguments and explicit function calls in the x4() + x5() step to force the order of evaluation and handle value/call duality.

<lang R>n <- function(x) function()x

A <- function(k, x1, x2, x3, x4, x5) { 

 B <- function() A(k <<- k-1, B, x1, x2, x3, x4)
 if (k <= 0) x4() + x5() else B()

}

A(10, n(1), n(-1), n(-1), n(1), n(0))</lang>

That is the way any sane person would implement Man-or-Boy. However, we can be a bit more evil than that. Here call.by.name is a function that rewrites the function definition given as its input:

<lang r>call.by.name <- function(...) { 

 cl <- as.list(match.call())
 sublist <- lapply(cl[2:(length(cl)-1)],
                   function(name) substitute(substitute(evalq(.,.caller),
                                                        list(.=substitute(name))),
                                             list(name=name)))
 names(sublist) <- enquote(cl[2:(length(cl)-1)])
 subcall <- do.call("call", c("list", lapply(sublist, enquote)))
 fndef <- cllength(cl)
 fndef3 <- substitute({
   .caller <- parent.frame()
   eval(substitute(body, subcall))
 }, list(body=fndef3, subcall=subcall))
 eval.parent(fndef)

}</lang>

allowing us to write A in a way that mirrors ALGOL60 semantics closely:

<lang R>A <- call.by.name(x1, x2, x3, x4, x5, 

 function(k, x1, x2, x3, x4, x5) {
   Aout <- NULL
   B <- function() {
     k <<- k - 1
     Bout <- Aout <<- A(k, B(), x1, x2, x3, x4)
   }
   if (k <= 0) Aout <- x4 + x5 else B()
   Aout
 }

)</lang>

One has to increase the recursion limit a bit, but it gives correct answers:

<lang r>> options(expressions=10000) > mapply(A, 0:10, 1, -1, -1, 1, 0) 

[1]   1   0  -2   0   1   0   1  -1 -10 -30 -67</lang>

If you inspect A without the original source you will see what has happened: call.by.name rewrote A so that it looks like this:

<lang r>> print(A, useSource=FALSE) function (k, x1, x2, x3, x4, x5) { 

   .caller <- parent.frame()
   eval(substitute({
       Aout <- NULL
       B <- function() {
           k <<- k - 1
           Bout <- Aout <<- A(k, B(), x1, x2, x3, x4)
       }
       if (k <= 0) Aout <- x4 + x5 else B()
       Aout
   }, list(x1 = substitute(evalq(., .caller), list(. = substitute(x1))), 
       x2 = substitute(evalq(., .caller), list(. = substitute(x2))), 
       x3 = substitute(evalq(., .caller), list(. = substitute(x3))), 
       x4 = substitute(evalq(., .caller), list(. = substitute(x4))), 
       x5 = substitute(evalq(., .caller), list(. = substitute(x5))))))

}</lang>

That is, instead of evaluating its arguments normally, A captures their original expressions, and instead of evaluating its body normally, A substitutes calls to evalq the captured argument expressions in the calling frame. After a few levels of recursion this way, you end up evaluating expressions like A(k, B(), evalq(B(), .caller), evalq(evalq(B(), .caller), .caller), evalq(evalq(evalq(1, .caller), .caller), .caller), evalq(evalq(evalq(-1, .caller), .caller), .caller)), so this is not very efficient, but works.

Ruby

Note: the lambda call can be replaced with Proc.new and still work. <lang ruby>def a(k, x1, x2, x3, x4, x5) 

 b = lambda { k -= 1; a(k, b, x1, x2, x3, x4) }
 k <= 0 ? x4[] + x5[] : b[]

end

puts a(10, lambda {1}, lambda {-1}, lambda {-1}, lambda {1}, lambda {0})</lang>

Scala

<lang scala>def A(in_k: Int, x1: =>Int, x2: =>Int, x3: =>Int, x4: =>Int, x5: =>Int): Int = { 

   var k = in_k
   def B: Int = {
       k = k-1
       A(k, B, x1, x2, x3, x4)
   }
   if (k<=0) x4+x5 else B

} println(A(10, 1, -1, -1, 1, 0))</lang>

Scheme

<lang scheme>(define (A k x1 x2 x3 x4 x5) 

 (define (B)
   (set! k (- k 1))
   (A k B x1 x2 x3 x4))
 (if (<= k 0)
     (+ (x4) (x5))
     (B)))

(A 10 (lambda () 1) (lambda () -1) (lambda () -1) (lambda () 1) (lambda () 0))</lang>

Smalltalk

Number>>x1: x1 x2: x2 x3: x3 x4: x4 x5: x5
   | b k |
   k := self.
   b := [ k := k - 1. k x1: b x2: x1 x3: x2 x4: x3 x5: x4 ].
   ^k <= 0 ifTrue: [ x4 value + x5 value ] ifFalse: b

10 x1: [1] x2: [-1] x3: [-1] x4: [1] x5: [0]

Standard ML

Standard ML variables are not mutable, so "k" is wrapped in a mutable object, which we access through a reference type called "ref".

<lang sml>fun a (k, x1, x2, x3, x4, x5) = 

 if k <= 0 then
   x4 () + x5 ()
 else let
   val m = ref k
   fun b () = (
     m := !m - 1;
     a (!m, b, x1, x2, x3, x4)
   )
 in
   b ()
 end

val () = 

 print (Int.toString (a (10, fn () => 1, fn () => ~1, fn () => ~1, fn () => 1, fn () => 0)) ^ "\n")</lang>

Tcl

There are two nontrivial features in the "man or boy" test. One is that the parameters x1 though x5 are in general going to be function calls that don't get evaluated until their values are needed for the addition in procedure A, which means that these in Tcl are going to be scripts, and therefore it is necessary to introduce a helper procedure C that returns a constant value. The other is that procedure B needs to refer to variables in the local context of its "parent" instance of procedure A. This is precisely what the upvar core command does, but the absolute target level needs to be embedded into the script that performs the delayed call to procedure B (upvar is more often used with relative levels). <lang tcl>proc A {k x1 x2 x3 x4 x5} { 

   expr {$k<=0 ? [eval $x4]+[eval $x5] : [B \#[info level]]}

} proc B {level} { 

   upvar $level k k x1 x1 x2 x2 x3 x3 x4 x4
   incr k -1
   A $k [info level 0] $x1 $x2 $x3 $x4

} proc C {val} {return $val} interp recursionlimit {} 1157 A 10 {C 1} {C -1} {C -1} {C 1} {C 0}</lang>

The [info level 0] here is a sort of "self" idiom; it returns the command (with arguments) that called the current procedure.

Since the values of x1 through x4 are never modified, it is also possible to embed these as parameters of B, thereby slightly purifying the program: <lang tcl>proc AP {k x1 x2 x3 x4 x5} {expr {$k<=0 ? [eval $x4]+[eval $x5] : [BP \#[info level] $x1 $x2 $x3 $x4]}} proc BP {level x1 x2 x3 x4} {AP [uplevel $level {incr k -1}] [info level 0] $x1 $x2 $x3 $x4} proc C {val} {return $val} interp recursionlimit {} 1157 AP 10 {C 1} {C -1} {C -1} {C 1} {C 0}</lang>

Vorpal

Adapted from the Lua example. In vorpal, all execution is a message to an object. This task primarily involves functions, so we have the apply the function objects to self for them to execute. Correctly, prints -67.

<lang vorpal>self.a = method(k, x1, x2, x3, x4, x5){ 

 b = method(){
   code.k = code.k - 1
   return( self.a(code.k, code, code.x1, code.x2, code.x3, code.x4) )
 }
 b.k = k
 b.x1 = x1
 b.x2 = x2
 b.x3 = x3
 b.x4 = x4
 b.x5 = x5

 if(k <= 0){
   return(self.apply(x4) + self.apply(x5))
 }
 else{
   return(self.apply(b))
 }

}

self.K = method(n){ 

 f = method(){
   return(code.n)
 }
 f.n = n
 return(f)

}

self.a(10, self.K(1), self.K(-1), self.K(-1), self.K(1), self.K(0)).print()</lang>

Retrieved from "https://rosettacode.org/wiki/Man_or_boy_test?oldid=52135"