2 setecho. 0 __settracegc. (* R E C U R S I V E D E F I N I T I O N *) (* fact(n) = IF n = 0 THEN 1 ELSE n * fact(n-1) *) DEFINE r-fact == [ null ] [ pop 1] [ dup pred r-fact *] ifte. [ 0 1 2 3 4 5 6 ] [r-fact] map. (* mcc91(i) = IF i > 100 THEN i - 10 ELSE mcc91(mcc91(i + 11)) *) DEFINE r-mcc91 == [ 100 > ] [ 10 - ] [ 11 + r-mcc91 r-mcc91 ] ifte. [ -7 42 99 100 101 102 345 ] [r-mcc91] map. (* ack(m, n) = IF m = 0 THEN n + 1 ELSEIF n = 0 THEN ack(m - 1, 1) ELSE ack(m - 1, ack(m, n - 1)) *) DEFINE r-ack == # stack putln [ [ [pop null] popd succ ] [ [null] pop pred 1 r-ack ] [ [dup pred swap] dip pred r-ack r-ack ] ] cond. [ [0 0] [0 1] [0 2] [0 3] [0 4] [0 5] ] [i r-ack] map putln [ [1 0] [1 1] [1 2] [1 3] [1 4] [1 5] ] [i r-ack] map putln [ [2 0] [2 1] [2 2] [2 3] [2 4] [2 5] ] [i r-ack] map putln [ [3 0] [3 1] [3 2] [3 3] [3 4] [3 5] ] [i r-ack] map putln [ [4 0] ] [i r-ack] map. # In the Towers of Hanoi puzzle the disks have to be moved # in a particular order. Ignoring what the target peg is, # for three disks the order is 1 2 1 3 1 2 1. # In general for n disks it is a sequence of (2^n)-1 steps. # The sequence of steps is also one that performs a # Hamiltonian path on an n-dimensional hypercube. # The following is the Joy program: DEFINE r-hamilhyp == # [] n => [...] [ null ] [ pop ] [ dup rollup pred r-hamilhyp dupd cons swap pred r-hamilhyp ] ifte. [] 3 r-hamilhyp. [] 4 r-hamilhyp. [] 5 r-hamilhyp. (* S E L F - A P P L I C A T I O N Reminder: x == dup i *) DEFINE x-fact == [ [ pop null ] [ pop pop 1] [ [dup pred] dip x *] ifte ] x. [ 0 1 2 3 4 5 6 ] [x-fact] map. DEFINE twice-x == dup [x] dip x. DEFINE x-mcc91 == [ [ pop 100 > ] [ pop 10 - ] [ [11 +] dip twice-x ] ifte ] x. [ -7 42 99 100 101 102 345 ] [x-mcc91] map. (* r-ack == # stack putln [ [ [pop null] popd succ ] [ [null] pop pred 1 r-ack ] [ [dup pred swap] dip pred r-ack r-ack ] ] cond. *) DEFINE x-ack == [ [ [ [pop pop null] pop popd succ ] [ [pop null] [pop pred 1] dip x ] [ [[dup pred swap] dip pred] dip twice-x ] ] cond ] x. [ [3 0] [3 1] [3 2] [3 3] [3 4] [3 5] ] [i x-ack] map. (* the following is for a non-recursive definition using the y-combinator *) DEFINE y == [dup cons] swoncat dup cons i; twice-i == dup [i] dip i. DEFINE y-ack == [ [ [ [pop pop null] pop popd succ ] [ [pop null] [pop pred 1] dip i ] [ [[dup pred swap] dip pred] dip twice-i ] ] cond ] y. [ [3 0] [3 1] [3 2] [3 3] [3 4] [3 5] ] [i y-ack] map. (* DEFINE r-hamilhyp == # [] n => [...] [ null ] [ pop ] [ dup rollup pred r-hamilhyp dupd cons swap pred r-hamilhyp ] ifte. *) DEFINE x-hamilhyp == [ [ pop null ] [ pop pop ] [ dup [ [dup rollup pred] dip x ] dip [dupd cons] dip [swap pred] dip x ] ifte ] x. [] 5 x-hamilhyp. (* P A R T I A L L Y E X P L I C I T R E C U R S I O N *) # Nick Forde suggested writing the Ackermann function by using # the linrec combinator to achieve one recursion, and to use # explicit recursion for the other. For reasons that do not concern # us here, his version computes the _converse_ of the text book # definition: DEFINE ack == (* I:n I:m -> I:a *) [ [ [0 =] [pop 1 +] ] [ [swap 0 =] [popd 1 - 1 swap] [] ] [ [dup rollup [1 -] dip] [swap 1 - ack] ] ] condlinrec . [ [0 0] [0 1] [0 2] [0 3] [0 4] [0 5] ] [i swap ack] map putln [ [1 0] [1 1] [1 2] [1 3] [1 4] [1 5] ] [i swap ack] map putln [ [2 0] [2 1] [2 2] [2 3] [2 4] [2 5] ] [i swap ack] map putln [ [3 0] [3 1] [3 2] [3 3] [3 4] [3 5] ] [i swap ack] map putln [ [4 0] ] [i swap ack] map. (* DEFINE r-mcc91 == [ 100 > ] [ 10 - ] [ 11 + r-mcc91 r-mcc91 ] ifte. *) DEFINE l-mcc91 == [ 100 > ] [ 10 - ] [ 11 + ] [ l-mcc91 ] linrec. [ -7 42 99 100 101 102 345 ] [x-mcc91] map. (* r-ack == # stack putln [ [ [pop null] popd succ ] [ [null] pop pred 1 r-ack ] [ [dup pred swap] dip pred r-ack r-ack ] ] cond. *) DEFINE clr-ack == [ [ [pop null] [popd succ] ] [ [null] [pop pred 1] [] ] [ [[dup pred swap] dip pred] [clr-ack] ] ] condlinrec. [ [3 0] [3 1] [3 2] [3 3] [3 4] [3 5] ] [i clr-ack] map. (* DEFINE r-hamilhyp == # [] n => [...] [ null ] [ pop ] [ dup rollup pred r-hamilhyp dupd cons swap pred r-hamilhyp ] ifte. *) DEFINE lr-hamilhyp == [ null ] [ pop ] [ dup rollup pred ] [ dupd cons swap pred lr-hamilhyp ] linrec. [] 5 lr-hamilhyp. DEFINE toggle == # {..} i -> {..] [has] [[not] dip swons not] [swons] ifte. {} 4 toggle. {1 2 7} 2 toggle. DEFINE lr-grayseq == [ null ] [ pop ] [ dup rollup pred ] [ dupd dup [first swap toggle] dip # inserted line cons swap pred lr-grayseq ] linrec. [{}] 3 lr-grayseq. [{3}] 3 lr-grayseq. [{1 2 3}] 3 lr-grayseq. (* N E S T E D R E C U R S I O N C O M B I N A T O R : condnestrec *) DEFINE cnr-hamilhyp == [ [ [null] [pop] ] [ [dup rollup pred] [dupd cons swap pred] [] ] ] condnestrec. [] 4 cnr-hamilhyp. DEFINE cnr-ack == [ [ [pop null] [popd succ] ] [ [null] [pop pred 1] [] ] [ [[dup pred swap] dip pred] [] [] ] ] condnestrec. 3 4 cnr-ack. DEFINE cnr-grayseq == [ [ [null] [pop] ] [ [dup rollup pred] [dupd dup [first swap toggle] dip # inserted cons swap pred] [] ] ] condnestrec. [{}] 3 cnr-grayseq. DEFINE cnr-hanoi == [[rolldown] infra] dip [ [ [null] [pop pop] ] [ [dup2 [[rotate] infra] dip pred] [ [dup rest put] dip [[swap] infra] dip pred ] [] ] ] condnestrec. [source destination temp] 2 cnr-hanoi. # [S D T] 5 cnr-hanoi. DEFINE cnr-fact == [ [ [null] [pop 1] ] [ [dup pred] [*] ] ] condnestrec; cnr-mcc91 == [ [ [100 >] [10 -] ] [ [11 +] [] [] ] ] condnestrec. [ 0 1 2 3 4 5 6 ] [cnr-fact] map. [ -7 42 99 100 101 102 345 ] [cnr-mcc91] map. # Using condnestrec for ordinary conditionals: DEFINE cnr-even == [ [ [2 rem null] [pop true] ] [ [pop false] ] ] condnestrec; cnr-abs == [ [ [0 <] [0 swap -] ] [ [] ] ] condnestrec. 3 cnr-even. 4 cnr-even. -5 cnr-abs. 6 cnr-abs. (* end of file *)