aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

September Morn Update

Browse source
This commit is contained in:
Ingy döt Net 2019-09-12 10:33:56 -07:00
parent 4e2d22a71d
commit aac6731f2c
6856 changed files with 141342 additions and 21127 deletions
Download patch file Download diff file Expand all files Collapse all files

250
Task/Y-combinator/ARM-Assembly/y-combinator.arm Normal file
View file

@ -0,0 +1,250 @@
/* ARM assembly Raspberry PI */
/* program Ycombi.s */
/* REMARK 1 : this program use routines in a include file
see task Include a file language arm assembly
for the routine affichageMess conversion10
see at end of this program the instruction include */
/* Constantes */
.equ STDOUT, 1 @ Linux output console
.equ EXIT, 1 @ Linux syscall
.equ WRITE, 4 @ Linux syscall
/*******************************************/
/* Structures */
/********************************************/
/* structure function*/
.struct 0
func_fn: @ next element
.struct func_fn + 4
func_f_: @ next element
.struct func_f_ + 4
func_num:
.struct func_num + 4
func_fin:
/* Initialized data */
.data
szMessStartPgm: .asciz "Program start \n"
szMessEndPgm: .asciz "Program normal end.\n"
szMessError: .asciz "\033[31mError Allocation !!!\n"
szFactorielle: .asciz "Function factorielle : \n"
szFibonacci: .asciz "Function Fibonacci : \n"
szCarriageReturn: .asciz "\n"
/* datas message display */
szMessResult: .ascii "Result value :"
sValue: .space 12,' '
.asciz "\n"
/* UnInitialized data */
.bss
/* code section */
.text
.global main
main: @ program start
ldr r0,iAdrszMessStartPgm @ display start message
bl affichageMess
adr r0,facFunc @ function factorielle address
bl YFunc @ create Ycombinator
mov r5,r0 @ save Ycombinator
ldr r0,iAdrszFactorielle @ display message
bl affichageMess
mov r4,#1 @ loop counter
1: @ start loop
mov r0,r4
bl numFunc @ create number structure
cmp r0,#-1 @ allocation error ?
beq 99f
mov r1,r0 @ structure number address
mov r0,r5 @ Ycombinator address
bl callFunc @ call
ldr r0,[r0,#func_num] @ load result
ldr r1,iAdrsValue @ and convert ascii string
bl conversion10
ldr r0,iAdrszMessResult @ display result message
bl affichageMess
add r4,#1 @ increment loop counter
cmp r4,#10 @ end ?
ble 1b @ no -> loop
/*********Fibonacci *************/
adr r0,fibFunc @ function factorielle address
bl YFunc @ create Ycombinator
mov r5,r0 @ save Ycombinator
ldr r0,iAdrszFibonacci @ display message
bl affichageMess
mov r4,#1 @ loop counter
2: @ start loop
mov r0,r4
bl numFunc @ create number structure
cmp r0,#-1 @ allocation error ?
beq 99f
mov r1,r0 @ structure number address
mov r0,r5 @ Ycombinator address
bl callFunc @ call
ldr r0,[r0,#func_num] @ load result
ldr r1,iAdrsValue @ and convert ascii string
bl conversion10
ldr r0,iAdrszMessResult @ display result message
bl affichageMess
add r4,#1 @ increment loop counter
cmp r4,#10 @ end ?
ble 2b @ no -> loop
ldr r0,iAdrszMessEndPgm @ display end message
bl affichageMess
b 100f
99: @ display error message
ldr r0,iAdrszMessError
bl affichageMess
100: @ standard end of the program
mov r0, #0 @ return code
mov r7, #EXIT @ request to exit program
svc 0 @ perform system call
iAdrszMessStartPgm: .int szMessStartPgm
iAdrszMessEndPgm: .int szMessEndPgm
iAdrszFactorielle: .int szFactorielle
iAdrszFibonacci: .int szFibonacci
iAdrszMessError: .int szMessError
iAdrszCarriageReturn: .int szCarriageReturn
iAdrszMessResult: .int szMessResult
iAdrsValue: .int sValue
/******************************************************************/
/* factorielle function */
/******************************************************************/
/* r0 contains the Y combinator address */
/* r1 contains the number structure */
facFunc:
push {r1-r3,lr} @ save registers
mov r2,r0 @ save Y combinator address
ldr r0,[r1,#func_num] @ load number
cmp r0,#1 @ > 1 ?
bgt 1f @ yes
mov r0,#1 @ create structure number value 1
bl numFunc
b 100f
1:
mov r3,r0 @ save number
sub r0,#1 @ decrement number
bl numFunc @ and create new structure number
cmp r0,#-1 @ allocation error ?
beq 100f
mov r1,r0 @ new structure number -> param 1
ldr r0,[r2,#func_f_] @ load function address to execute
bl callFunc @ call
ldr r1,[r0,#func_num] @ load new result
mul r0,r1,r3 @ and multiply by precedent
bl numFunc @ and create new structure number
@ and return her address in r0
100:
pop {r1-r3,lr} @ restaur registers
bx lr @ return
/******************************************************************/
/* fibonacci function */
/******************************************************************/
/* r0 contains the Y combinator address */
/* r1 contains the number structure */
fibFunc:
push {r1-r4,lr} @ save registers
mov r2,r0 @ save Y combinator address
ldr r0,[r1,#func_num] @ load number
cmp r0,#1 @ > 1 ?
bgt 1f @ yes
mov r0,#1 @ create structure number value 1
bl numFunc
b 100f
1:
mov r3,r0 @ save number
sub r0,#1 @ decrement number
bl numFunc @ and create new structure number
cmp r0,#-1 @ allocation error ?
beq 100f
mov r1,r0 @ new structure number -> param 1
ldr r0,[r2,#func_f_] @ load function address to execute
bl callFunc @ call
ldr r4,[r0,#func_num] @ load new result
sub r0,r3,#2 @ new number - 2
bl numFunc @ and create new structure number
cmp r0,#-1 @ allocation error ?
beq 100f
mov r1,r0 @ new structure number -> param 1
ldr r0,[r2,#func_f_] @ load function address to execute
bl callFunc @ call
ldr r1,[r0,#func_num] @ load new result
add r0,r1,r4 @ add two results
bl numFunc @ and create new structure number
@ and return her address in r0
100:
pop {r1-r4,lr} @ restaur registers
bx lr @ return
/******************************************************************/
/* call function */
/******************************************************************/
/* r0 contains the address of the function */
/* r1 contains the address of the function 1 */
callFunc:
push {r2,lr} @ save registers
ldr r2,[r0,#func_fn] @ load function address to execute
blx r2 @ and call it
pop {r2,lr} @ restaur registers
bx lr @ return
/******************************************************************/
/* create Y combinator function */
/******************************************************************/
/* r0 contains the address of the function */
YFunc:
push {r1,lr} @ save registers
mov r1,#0
bl newFunc
cmp r0,#-1 @ allocation error ?
strne r0,[r0,#func_f_] @ store function and return in r0
pop {r1,lr} @ restaur registers
bx lr @ return
/******************************************************************/
/* create structure number function */
/******************************************************************/
/* r0 contains the number */
numFunc:
push {r1,r2,lr} @ save registers
mov r2,r0 @ save number
mov r0,#0 @ function null
mov r1,#0 @ function null
bl newFunc
cmp r0,#-1 @ allocation error ?
strne r2,[r0,#func_num] @ store number in new structure
pop {r1,r2,lr} @ restaur registers
bx lr @ return
/******************************************************************/
/* new function */
/******************************************************************/
/* r0 contains the function address */
/* r1 contains the function address 1 */
newFunc:
push {r2-r7,lr} @ save registers
mov r4,r0 @ save address
mov r5,r1 @ save adresse 1
@ allocation place on the heap
mov r0,#0 @ allocation place heap
mov r7,#0x2D @ call system 'brk'
svc #0
mov r3,r0 @ save address heap for output string
add r0,#func_fin @ reservation place one element
mov r7,#0x2D @ call system 'brk'
svc #0
cmp r0,#-1 @ allocation error
beq 100f
mov r0,r3
str r4,[r0,#func_fn] @ store address
str r5,[r0,#func_f_]
mov r2,#0
str r2,[r0,#func_num] @ store zero to number
100:
pop {r2-r7,lr} @ restaur registers
bx lr @ return
/***************************************************/
/* ROUTINES INCLUDE */
/***************************************************/
.include "../affichage.inc"

40
Task/Y-combinator/Common-Lisp/y-combinator.lisp
View file

@ -1,25 +1,29 @@
(defun Y (f)
((lambda (x) (funcall x x))
(lambda (y)
(funcall f (lambda (&rest args)
(apply (funcall y y) args))))))
((lambda (g) (funcall g g))
(lambda (g)
(funcall f (lambda (&rest a)
(apply (funcall g g) a))))))
(defun fac (f)
(lambda (n)
(if (zerop n)
1
(* n (funcall f (1- n))))))
(defun fac (n)
(funcall
(Y (lambda (f)
(lambda (n)
(if (zerop n)
1
(* n (funcall f (1- n)))))))
n))
(defun fib (f)
(lambda (n)
(case n
(0 0)
(1 1)
(otherwise (+ (funcall f (- n 1))
(funcall f (- n 2)))))))
(defun fib (n)
(funcall
(Y (lambda (f)
(lambda (n a b)
(if (< n 1)
a
(funcall f (1- n) b (+ a b))))))
n 0 1))
? (mapcar (Y #'fac) '(1 2 3 4 5 6 7 8 9 10))
? (mapcar #'fac '(1 2 3 4 5 6 7 8 9 10))
(1 2 6 24 120 720 5040 40320 362880 3628800))
? (mapcar (Y #'fib) '(1 2 3 4 5 6 7 8 9 10))
? (mapcar #'fib '(1 2 3 4 5 6 7 8 9 10))
(1 1 2 3 5 8 13 21 34 55)

20
Task/Y-combinator/Elena/y-combinator.elena
View file

@ -1,16 +1,16 @@
import extensions.
import extensions;
singleton YCombinator
{
fix : func
= (:f)[(:x)[ x(x) ] eval(:g)[ f eval(:x)[(g(g)) eval:x] ]] eval:func.
fix(func)
= (f){(x){ x(x) }((g){ f((x){ (g(g))(x) })})}(func);
}
program =
[
var fib := YCombinator fix(:f)((:i)( (i <= 1) ifTrue:[^i] ifFalse:[^f(i-1) + f(i-2) ] )).
var fact := YCombinator fix(:f)((:i)((i == 0) ifTrue:[^1] ifFalse:[^f(i-1) * i] )).
public program()
{
var fib := YCombinator.fix:(f => (i => (i <= 1) ? i : (f(i-1) + f(i-2)) ));
var fact := YCombinator.fix:(f => (i => (i == 0) ? 1 : (f(i-1) * i) ));
console printLine("fib(10)=",fib(10)).
console printLine("fact(10)=",fact(10)).
].
console.printLine("fib(10)=",fib(10));
console.printLine("fact(10)=",fact(10));
}

37
Task/Y-combinator/Haskell/y-combinator-1.hs
View file

@ -6,22 +6,41 @@ fix = g <*> (Roll . g)
where
g = (. (>>= id) unroll)
- this version is not in tail call position...
-- fac :: Integer -> Integer
-- fac =
-- fix $ \f n -> if n <= 0 then 1 else n * f (n - 1)
-- this version builds a progression from tail call position and is more efficient...
fac :: Integer -> Integer
fac =
fix $
\f n ->
(if n <= 0
then 1
else n * f (n - 1))
(fix $ \f n i -> if i <= 0 then n else f (i * n) (i - 1)) 1
fibs :: [Integer]
fibs =
fix $ (0 :) . (1 :) . (fix (\f (x:xs) (y:ys) -> x + y : f xs ys) <*> tail)
-- make fibs a function, else memory leak as
-- head of the list can never be released as per:
-- https://wiki.haskell.org/Memory_leak, type 1.1
-- overly complex version...
{--
fibs :: () -> [Integer]
fibs() =
fix $
(0 :) . (1 :) .
(fix
(\f (x:xs) (y:ys) ->
case x + y of n -> n `seq` n : f xs ys) <*> tail)
--}
-- easier to read, simpler (faster) version...
fibs :: () -> [Integer]
fibs() = 0 : 1 : fix fibs_ 0 1
where
fibs_ fnc f s =
case f + s of n -> n `seq` n : fnc s n
main :: IO ()
main =
mapM_
print
[ map fac [1 .. 20]
, take 20 fibs
, take 20 $ fibs()
]

52
Task/Y-combinator/Haskell/y-combinator-2.hs
View file

@ -1,36 +1,48 @@
-- note that this version of fix uses function recursion in its own definition;
-- thus its use just means that the recursion has been "pulled" into the "fix" function,
-- instead of the function that uses it...
fix :: (a -> a) -> a
fix f = f (fix f) -- _not_ the {fix f = x where x = f x}
fac :: Integer -> Integer
fac_ f n
| n <= 0 = 1
| otherwise = n * f (n - 1)
fac =
(fix $
\f n i ->
if i <= 0 then n
else f (i * n) (i - 1)) 1
fac = fix fac_ -- fac_ (fac_ . fac_ . fac_ . fac_ . ...)
-- a simple but wasteful exponential time definition:
fib :: Integer -> Integer
fib_ f 0 = 0
fib_ f 1 = 1
fib_ f n = f (n - 1) + f (n - 2)
fib =
(fix $
\fnc f s i ->
if i <= 1 then f
else case f + s of n -> n `seq` fnc s n (i - 1)) 0 1
fib = fix fib_
-- Or for far more efficiency, compute a lazy infinite list. This is
-- a Y-combinator version of: fibs = 0:1:zipWith (+) fibs (tail fibs)
fibs :: [Integer]
fibs_ a = 0 : 1 : fix zipP a (tail a)
{--
-- compute a lazy infinite list. This is
-- a Y-combinator version of: fibs() = 0:1:zipWith (+) fibs (tail fibs)
-- which is the same as the above version but easier to read...
fibs :: () -> [Integer]
fibs() = fix fibs_
where
zipP f (x:xs) (y:ys) = x + y : f xs ys
zipP f (x:xs) (y:ys) =
case x + y of n -> n `seq` n : f xs ys
fibs_ a = 0 : 1 : fix zipP a (tail a)
--}
fibs = fix fibs_
-- easier to read, simpler (faster) version...
fibs :: () -> [Integer]
fibs() = 0 : 1 : fix fibs_ 0 1
where
fibs_ fnc f s =
case f + s of n -> n `seq` n : fnc s n
-- This code shows how the functions can be used:
main : IO ()
main :: IO ()
main =
mapM_
print
[ map fac [1 .. 20]
, map fib [0 .. 19]
, take 20 fibs
, map fib [1 .. 20]
, take 20 fibs()
]

4
Task/Y-combinator/J/y-combinator-1.j
View file

@ -1 +1,3 @@
Y=. ((((&>)/)((((^:_1)b.)(`(<'0';_1)))(`:6)))(&([ 128!:2 ,&<)))
Y=. '('':''<@;(1;~":0)<@;<@((":0)&;))'(2 : 0 '')
(1 : (m,'u'))(1 : (m,'''u u`:6('',(5!:5<''u''),'')`:6 y'''))(1 :'u u`:6')
)

6
Task/Y-combinator/J/y-combinator-10.j Normal file
View file

@ -0,0 +1,6 @@
sr=. [ apply f.,&< NB. Self referring
lv=. (((^:_1)b.)(`(<'0';_1)))(`:6) NB. Linear representation of a verb argument
Y=. (&>)/lv(&sr) NB. Y with embedded states
Y=. 'Y'f. NB. Fixing it...
Y NB. ... To make it stateless (i.e., a combinator)
((((&>)/)((((^:_1)b.)(`_1))(`:6)))(&([ 128!:2 ,&<)))

20
Task/Y-combinator/J/y-combinator-11.j Normal file
View file

@ -0,0 +1,20 @@
Y=:1 :0
f=. u Defer
(5!:1<'f') f y
)
Defer=: 1 :0
:
g=. x&(x`:6)
(5!:1<'g') u y
)
almost_factorial=: 4 :0
if. 0 >: y do. 1
else. y * x`:6 y-1 end.
)
almost_fibonacci=: 4 :0
if. 2 > y do. y
else. (x`:6 y-1) + x`:6 y-2 end.
)

6
Task/Y-combinator/J/y-combinator-12.j Normal file
View file

@ -0,0 +1,6 @@
almost_factorial Y 9
362880
almost_fibonacci Y 9
34
almost_fibonacci Y"0 i. 10
0 1 1 2 3 5 8 13 21 34

9
Task/Y-combinator/J/y-combinator-13.j Normal file
View file

@ -0,0 +1,9 @@
Y=:2 :0(0 :0)
NB. this block will be n in the second part
:
g=. x&(x`:6)
(5!:1<'g') u y
)
f=. u (1 :n)
(5!:1<'f') f y
)

2
Task/Y-combinator/J/y-combinator-14.j Normal file
View file

@ -0,0 +1,2 @@
almost_factorial f. Y 10
3628800

11
Task/Y-combinator/J/y-combinator-2.j
View file

@ -1,11 +1,4 @@
u=. [ NB. Function (left)
n=. ] NB. Argument (right)
sr=. [ apply f. ,&< NB. Self referring
fac=. (1:`(n * u sr n - 1:)) @. (0 < n)
fac f. Y 10
'if. * y do. y * u <: y else. 1 end.' Y 10 NB. Factorial
3628800
Fib=. ((u sr n - 2:) + u sr n - 1:) ^: (1 < n)
Fib f. Y 10
'(u@:<:@:<: + u@:<:)^:(1 < ])' Y 10 NB. Fibonacci
55

15
Task/Y-combinator/J/y-combinator-3.j
View file

@ -1,12 +1,7 @@
fac f. Y NB. Showing the stateless recursive factorial function...
'1:`(] * [ ([ 128!:2 ,&<) ] - 1:)@.(0 < ])&>/'&([ 128!:2 ,&<)
arb=. ':'<@;(1;~":0)<@;<@((":0)&;) NB. AR of an explicit adverb from its body
fac f. NB. Showing the stateless factorial step...
1:`(] * [ ([ 128!:2 ,&<) ] - 1:)@.(0 < ])
ara=. 1 :'arb u' NB. The verb arb as an adverb
srt=. 1 :'arb ''u u`:6('' , (5!:5<''u'') , '')`:6 y''' NB. AR of the self-replication and transformation adverb
gab=. 1 :'u u`:6' NB. The AR of the adverb and the adverb itself as a train
Fib f. Y NB. Showing the stateless recursive Fibonacci function...
'(([ ([ 128!:2 ,&<) ] - 2:) + [ ([ 128!:2 ,&<) ] - 1:)^:(1 < ])&>/'&([ 128!:2 ,&<)
Fib f. NB. Showing the stateless Fibonacci step...
(([ ([ 128!:2 ,&<) ] - 2:) + [ ([ 128!:2 ,&<) ] - 1:)^:(1 < ])
Y=. ara srt gab NB. Train of adverbs

5
Task/Y-combinator/J/y-combinator-4.j
View file

@ -1,4 +1 @@
sr=. [ apply f.,&< NB. Self referring
lv=. (((^:_1)b.)(`(<'0';_1)))(`:6) NB. Linear representation of a verb argument
Y=. (&>)/lv(&sr) f. NB. Y combinator
Y=. 'Y'f. NB. Fixing it
XY=. (1 :'('':''<@;(1;~":0)<@;<@((":0)&;))u')(1 :'('':''<@;(1;~":0)<@;<@((":0)&;))((''u u`:6('',(5!:5<''u''),'')`:6 y''),(10{a.),'':'',(10{a.),''x(u u`:6('',(5!:5<''u''),'')`:6)y'')')(1 :'u u`:6')

54
Task/Y-combinator/J/y-combinator-5.j
View file

@ -1,40 +1,14 @@
lambda=:3 :0
if. 1=#;:y do.
3 :(y,'=.y',LF,0 :0)`''
else.
(,<#;:y) Defer (3 :('''',y,'''=.y',LF,0 :0))`''
end.
)
Defer=:2 :0
if. (_1 {:: m) <: #m do.
v |. y;_1 }. m
else.
(y;m) Defer v`''
end.
)
recursivelY=: lambda 'g recur x'
(g`:6 recur`:6 recur)`:6 x
)
sivelY=: lambda 'g recur'
(recursivelY`:6 g)`:6 recur
)
Y=: lambda 'g'
recur=. sivelY`:6 g
recur`:6 recur
)
almost_factorial=: lambda 'f n'
if. 0 >: n do. 1
else. n * f`:6 n-1 end.
)
almost_fibonacci=: lambda 'f n'
if. 2 > n do. n
else. (f`:6 n-1) + f`:6 n-2 end.
)
Ev=: `:6
1 2 3 '([:`(>:@:])`(<:@:[ u 1:)`(<:@[ u [ u <:@:])@.(#.@,&*))'XY"0/ 1 2 3 4 5 NB. Ackermann function...
3 4 5 6 7
5 7 9 11 13
13 29 61 125 253
'1:`(<: u <:)@.* : (+ + 2 * u@:])'XY"0/~ i.7 NB. Ambivalent recursion...
2 5 14 35 80 173 362
3 6 15 36 81 174 363
4 7 16 37 82 175 364
5 8 17 38 83 176 365
6 9 18 39 84 177 366
7 10 19 40 85 178 367
8 11 20 41 86 179 368
NB. OEIS A097813 - main diagonal
NB. OEIS A050488 = A097813 - 1 - adyacent upper off-diagonal

7
Task/Y-combinator/J/y-combinator-6.j
View file

@ -1,6 +1 @@
(Y Ev almost_factorial)Ev 9
362880
(Y Ev almost_fibonacci)Ev 9
34
(Y Ev almost_fibonacci)Ev"0 i. 10
0 1 1 2 3 5 8 13 21 34
YX=. (1 :'('':''<@;(1;~":0)<@;<@((":0)&;))u')($:`)(`:6)

1
Task/Y-combinator/J/y-combinator-7.j Normal file
View file

@ -0,0 +1 @@
Y=. ((((&>)/)((((^:_1)b.)(`(<'0';_1)))(`:6)))(&([ 128!:2 ,&<)))

11
Task/Y-combinator/J/y-combinator-8.j Normal file
View file

@ -0,0 +1,11 @@
u=. [ NB. Function (left)
n=. ] NB. Argument (right)
sr=. [ apply f. ,&< NB. Self referring
fac=. (1:`(n * u sr n - 1:)) @. (0 < n)
fac f. Y 10
3628800
Fib=. ((u sr n - 2:) + u sr n - 1:) ^: (1 < n)
Fib f. Y 10
55

12
Task/Y-combinator/J/y-combinator-9.j Normal file
View file

@ -0,0 +1,12 @@
fac f. Y NB. Factorial...
'1:`(] * [ ([ 128!:2 ,&<) ] - 1:)@.(0 < ])&>/'&([ 128!:2 ,&<)
fac f. NB. Factorial step...
1:`(] * [ ([ 128!:2 ,&<) ] - 1:)@.(0 < ])
Fib f. Y NB. Fibonacci...
'(([ ([ 128!:2 ,&<) ] - 2:) + [ ([ 128!:2 ,&<) ] - 1:)^:(1 < ])&>/'&([ 128!:2 ,&<)
Fib f. NB. Fibonacci step...
(([ ([ 128!:2 ,&<) ] - 2:) + [ ([ 128!:2 ,&<) ] - 1:)^:(1 < ])

2
Task/Y-combinator/Java/y-combinator-1.java
View file

@ -16,7 +16,7 @@ public interface YCombinator {
Function<Integer,Integer> fac = Y(f -> n ->
(n <= 1)
? 1
: (n * f.apply(n - 1));
: (n * f.apply(n - 1))
);
System.out.println("fib(10) = " + fib.apply(10));

26
Task/Y-combinator/Phix/y-combinator.phix Normal file
View file

@ -0,0 +1,26 @@
function call_fn(integer f, n)
return call_func(f,{f,n})
end function
function Y(integer f)
return f
end function
function fac(integer self, integer n)
return iff(n>1?n*call_fn(self,n-1):1)
end function
function fib(integer self, integer n)
return iff(n>1?call_fn(self,n-1)+call_fn(self,n-2):n)
end function
procedure test(string name, integer rid=routine_id(name))
integer f = Y(rid)
printf(1,"%s: ",{name})
for i=1 to 10 do
printf(1," %d",call_fn(f,i))
end for
printf(1,"\n");
end procedure
test("fac")
test("fib")

6
Task/Y-combinator/Racket/y-combinator-1.rkt
View file

@ -1,8 +1,8 @@
#lang lazy
(define Y (λ(f)((λ(x)(f (x x)))(λ(x)(f (x x))))))
(define Y (λ (f) ((λ (x) (f (x x))) (λ (x) (f (x x))))))
(define Fact
(Y (λ(fact) (λ(n) (if (zero? n) 1 (* n (fact (- n 1))))))))
(Y (λ (fact) (λ (n) (if (zero? n) 1 (* n (fact (- n 1))))))))
(define Fib
(Y (λ(fib) (λ(n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2))))))))
(Y (λ (fib) (λ (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2))))))))

4
Task/Y-combinator/Racket/y-combinator-2.rkt
View file

@ -1,3 +1,3 @@
#lang racket
(define Y (λ(b)((λ(f)(b(λ(x)((f f) x))))
(λ(f)(b(λ(x)((f f) x)))))))
(define Y (λ (b) ((λ (f) (b (λ (x) ((f f) x))))
(λ (f) (b (λ (x) ((f f) x)))))))

133
Task/Y-combinator/Rust/y-combinator.rust
View file

@ -9,8 +9,13 @@
// We introduce a trait that will allow us to have an input with the same type as self, and break the recursion.
// The input is going to be a trait object that implements the desired function in the interface.
// NOTE: We will be coercing a reference to a closure into this trait object.
trait Apply<T, R> {
fn apply( &self, &Apply<T, R >, T ) -> R;
fn apply(
&self,
&Apply<T, R>,
T
) -> R;
}
// In Rust, closures fall into three kinds: FnOnce, FnMut and Fn.
@ -21,67 +26,103 @@ trait Apply<T, R> {
// that is not Clone.
// All Fn are also FnMut, and all closures of Fn are also Clone. However, programmers can create
// Fn objects that are not Clone
// The following address all closures that is Clone, and those are Fn.
impl<T, R, F> Apply<T, R> for F where F: FnOnce( &Apply<T, R>, T ) -> R + Clone {
fn apply( &self, f: &Apply<T, R>, t: T ) -> R {
(self.clone())( f, t )
// If we were to pass in self as f, we get -
// NOTE: Each letter is an individual symbol.
// λf.λt.sft
// => λs.λt.sst [s/f]
// => λs.ss
}
}
//This will work for all Fn objects, not just closures
//And it is a little bit more efficient for Fn closures as it do not clone itself.
//However under 1.26 it is not possible to define both. We will
//need to wait for specialization.
//impl<T, R, F> Apply<T, R> for F where F: Fn( &Apply<T, R>, T ) -> R {
// fn apply( &self, f: &Apply<T, R>, t: T ) -> R {
// self( f, t )
//}
//Before 1.26 we have some limitations and so we need some workarounds. But now impl Trait is stable and we can
// write the following:
fn y<T,R>(f:impl FnOnce(&Fn(T) -> R, T) -> R + Clone) -> impl FnOnce(T) -> R {
|t| (|x: &Apply<T,R>,y| x.apply(x,y))
(&move |x:&Apply<T,R>,y| f(&|z| x.apply(x,z), y), t)
// This will work for all Fn objects, not just closures
// And it is a little bit more efficient for Fn closures as it do not clone itself.
impl<T, R, F> Apply<T, R> for F where F:
Fn(&Apply<T, R>, T) -> R
{
fn apply(
&self,
f: &Apply<T, R>,
t: T
) -> R {
self(f, t)
// NOTE: Each letter is an individual symbol.
// (λx.(λy.xxy))(λx.(λy.f(λz.xxz)y))t
// => (λx.xx)(λx.f(xx))t
// => (Yf)t
}
}
//Previous version removed as they are just hacks when impl Trait is not available.
// This works for all closures that is Clone, and those are Fn.
// impl<T, R, F> Apply<T, R> for F where F: FnOnce( &Apply<T, R>, T ) -> R + Clone {
// fn apply( &self, f: &Apply<T, R>, t: T ) -> R {
// (self.clone())( f, t )
fn fac( n: usize ) -> usize {
let almost_fac = |f: &Fn( usize ) -> usize, x| if x == 0 { 1 } else { x * f( x - 1 ) };
let fac = y( almost_fac );
fac( n )
// // If we were to pass in self as f, we get -
// // NOTE: Each letter is an individual symbol.
// // λf.λt.sft
// // => λs.λt.sst [s/f]
// // => λs.ss
// }
// }
// Before 1.26 we have some limitations and so we need some workarounds. But now impl Trait is stable and we can
// write the following:
fn y<T,R>(f:impl Fn(&Fn(T) -> R, T) -> R) -> impl Fn(T) -> R {
move |t| (
|x: &Apply<T,R>, y| x.apply(x, y)
) (
&|x: &Apply<T,R>, y| f(
&|z| x.apply(x,z),
y
),
t
)
}
// fn y<T,R>(f:impl FnOnce(&Fn(T) -> R, T) -> R + Clone) -> impl FnOnce(T) -> R {
// |t| (|x: &Apply<T,R>,y| x.apply(x,y))
// (&move |x:&Apply<T,R>,y| f(&|z| x.apply(x,z), y), t)
// // NOTE: Each letter is an individual symbol.
// // (λx.(λy.xxy))(λx.(λy.f(λz.xxz)y))t
// // => (λx.xx)(λx.f(xx))t
// // => (Yf)t
// }
// Previous version removed as they are just hacks when impl Trait is not available.
fn fac(n: usize) -> usize {
let almost_fac = |f: &Fn(usize) -> usize, x|
if x == 0 {
1
} else {
x * f(x - 1)
}
;
let fac = y( almost_fac );
fac(n)
}
fn fib( n: usize ) -> usize {
let almost_fib = |f: &Fn( usize ) -> usize, x| if x < 2 { 1 } else { f( x - 2 ) + f( x - 1 ) };
let fib = y( almost_fib );
fib( n )
let almost_fib = |f: &Fn(usize) -> usize, x|
if x < 2 {
1
} else {
f(x - 2) + f(x - 1)
};
let fib = y(almost_fib);
fib(n)
}
fn optimal_fib( n: usize ) -> usize {
let almost_fib = |f: &Fn( (usize,usize,usize) ) -> usize, (i0,i1,x)|
{
match x {
0 => i0,
1 => i1,
x => f((i1,i0+i1, x-1))
}
};
let fib = |x|y( almost_fib )((1,1,x));
fib( n )
let almost_fib = |f: &Fn((usize,usize,usize)) -> usize, (i0,i1,x)|
match x {
0 => i0,
1 => i1,
x => f((i1,i0+i1, x-1))
}
;
let fib = |x| y(almost_fib)((1,1,x));
fib(n)
}
fn main() {
println!( "{}", fac( 10 ) );
println!( "{}", fib( 10 ) );
println!( "{}", optimal_fib( 10 ) );
println!("{}", fac(10));
println!("{}", fib(10));
println!("{}", optimal_fib(10));
}

61
Task/Y-combinator/Scheme/y-combinator-1.ss
View file

@ -1,38 +1,47 @@
(define Y
(lambda (h)
((lambda (x) (x x))
(define Y ; (Y f) = (g g) where
(lambda (f) ; (g g) = (f (lambda a (apply (g g) a)))
((lambda (g) (g g)) ; (Y f) == (f (lambda a (apply (Y f) a)))
(lambda (g)
(h (lambda args (apply (g g) args)))))))
(f (lambda a (apply (g g) a)))))))
;; head-recursive factorial
(define fac
(Y
(lambda (f)
(lambda (x)
(if (< x 2)
1
(* x (f (- x 1))))))))
(define fac ; fac = (Y f) = (f (lambda a (apply (Y f) a)))
(Y (lambda (r) ; = (lambda (x) ... (r (- x 1)) ... )
(lambda (x) ; where r = (lambda a (apply (Y f) a))
(if (< x 2) ; (r ... ) == ((Y f) ... )
1 ; == (lambda (x) ... (fac (- x 1)) ... )
(* x (r (- x 1))))))))
;; tail-recursive factorial
(define (fac2 n)
(letrec ((tail-fac
(Y (lambda (f)
(lambda (n acc)
(if (zero? n)
acc
(f (- n 1) (* n acc))))))))
(tail-fac n 1)))
(define fac2
(lambda (x)
((Y (lambda (r) ; (Y f) == (f (lambda a (apply (Y f) a)))
(lambda (x acc) ; r == (lambda a (apply (Y f) a))
(if (< x 2) ; (r ... ) == ((Y f) ... )
acc
(r (- x 1) (* x acc))))))
x 1)))
; double-recursive Fibonacci
(define fib
(Y
(lambda (f)
(lambda (x)
(if (< x 2)
x
(+ (f (- x 1)) (f (- x 2))))))))
(Y (lambda (f)
(lambda (x)
(if (< x 2)
x
(+ (f (- x 1)) (f (- x 2))))))))
; tail-recursive Fibonacci
(define fib2
(lambda (x)
((Y (lambda (f)
(lambda (x a b)
(if (< x 1)
a
(f (- x 1) b (+ a b))))))
x 0 1)))
(display (fac 6))
(newline)
(display (fib 6))
(display (fib2 134))
(newline)

6
Task/Y-combinator/Scheme/y-combinator-2.ss
View file

@ -1,3 +1,3 @@
(define Y
(lambda (h)
(lambda args (apply (h (Y h)) args))))
(define Yr ; (Y f) == (f (lambda a (apply (Y f) a)))
(lambda (f)
(f (lambda a (apply (Yr f) a)))))

3
Task/Y-combinator/Scheme/y-combinator-3.ss Normal file
View file

@ -0,0 +1,3 @@
(define Y2r
(lambda (f)
(lambda a (apply (f (Y2r f)) a))))

5
Task/Y-combinator/Scheme/y-combinator-4.ss Normal file
View file

@ -0,0 +1,5 @@
(define Y2 ; (Y2 f) = (g g) where
(lambda (f) ; (g g) = (lambda a (apply (f (g g)) a))
((lambda (g) (g g)) ; (Y2 f) == (lambda a (apply (f (Y2 f)) a))
(lambda (g)
(lambda a (apply (f (g g)) a))))))

38
Task/Y-combinator/VBA/y-combinator.vba Normal file
View file

@ -0,0 +1,38 @@
Private Function call_fn(f As String, n As Long) As Long
call_fn = Application.Run(f, f, n)
End Function
Private Function Y(f As String) As String
Y = f
End Function
Private Function fac(self As String, n As Long) As Long
If n > 1 Then
fac = n * call_fn(self, n - 1)
Else
fac = 1
End If
End Function
Private Function fib(self As String, n As Long) As Long
If n > 1 Then
fib = call_fn(self, n - 1) + call_fn(self, n - 2)
Else
fib = n
End If
End Function
Private Sub test(name As String)
Dim f As String: f = Y(name)
Dim i As Long
Debug.Print name
For i = 1 To 10
Debug.Print call_fn(f, i);
Next i
Debug.Print
End Sub
Public Sub main()
test "fac"
test "fib"
End Sub