Skip to content

Commit 01cc684

Browse files
author
Johan Wiltink
committed
change to binary-scott
1 parent 5caae41 commit 01cc684

File tree

3 files changed

+213
-31
lines changed

3 files changed

+213
-31
lines changed

‎tests/prime-sieve/solution-scott.txt‎

Lines changed: 135 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,135 @@
1+
# JohanWiltink
2+
3+
# primes
4+
# according to The Real Sieve of Erathosthenes
5+
6+
# B :: (b -> c) -> (a -> b) -> (a -> c)
7+
B = \ f g x . f (g x)
8+
9+
# data Int :: Zero | Succ Int
10+
11+
# succ :: Int -> Int
12+
succ = \ n . \ zero succ . succ n
13+
14+
# plus :: Int -> Int -> Int
15+
plus = \ m n . n m (B succ (plus m))
16+
17+
# mult :: Int -> Int -> Int
18+
mult = \ m n . n n (B (plus m) (mult m))
19+
20+
# minus :: Int -> Int -> Int
21+
minus = \ m n . m m (B (n m) minus)
22+
23+
# data Bool :: False | True
24+
25+
# false :: Bool
26+
false = \ false true . false
27+
28+
# true :: Bool
29+
true = \ false true . true
30+
31+
# isZero :: Int -> Bool
32+
isZero = \ n . n true ( \ n-1 . false )
33+
34+
# EQ :: Int -> Int -> Bool
35+
EQ = \ m n . m (isZero n) (B (n false) EQ)
36+
37+
# data Pair a b :: Pair a b
38+
39+
# pair :: a -> b -> Pair a b
40+
pair = \ x y . \ pair . pair x y
41+
42+
# fst :: Pair a b -> a
43+
fst = \ xy . xy ( \ x y . x )
44+
45+
# snd :: Pair a b -> b
46+
snd = \ xy . xy ( \ x y . y )
47+
48+
# data Stream a :: Cons a (Stream a)
49+
50+
# cons :: a -> Stream a -> Stream a
51+
cons = \ x xs . \ cons . cons x xs
52+
53+
# head :: Stream a -> a
54+
head = \ xs . xs ( \ x xs . x )
55+
56+
# tail :: Stream a -> Stream a
57+
tail = \ xs . xs ( \ x xs . xs )
58+
59+
# map :: (a -> b) -> Stream a -> Stream b
60+
map = \ fn xs . xs ( \ x xs . cons (fn x) (map fn xs) )
61+
62+
# iterate :: (a -> a) -> a -> Stream a
63+
iterate = \ fn x . cons x (iterate fn (fn x))
64+
65+
# LE :: Int -> Int -> Bool
66+
# LE = \ m n . isZero (minus m n)
67+
# LE = \ m n . m true (B (n false) LE) # probably equal performance
68+
69+
# LE :: Stream Int -> Stream Int -> Bool
70+
LE = \ m n . isZero (minus (head m) (head n)) # no need to order on subsequent elements
71+
72+
# data Set a = Nil | Branch a (Set a) (Set a)
73+
74+
# empty :: Set a
75+
empty = \ nil branch . nil
76+
77+
# branch :: a -> Set a -> Set a -> Set a
78+
branch = \ x left right . \ nil branch . branch x left right
79+
80+
# insert :: (Ord a) => a -> Set a -> Set a
81+
insert = \ x set .
82+
set
83+
(branch x empty empty)
84+
( \ y left right .
85+
LE x y
86+
(branch y left (insert x right))
87+
(branch y (insert x left) right)
88+
)
89+
90+
# findMin :: (Partial) => Set a -> a
91+
findMin = \ set . set ()
92+
\ x left right .
93+
left x ( \ _ _ _ . findMin left )
94+
95+
# minView :: (Partial) => Set a -> (a,Set a)
96+
minView = \ set . set ()
97+
\ x left right .
98+
left
99+
(pair x right)
100+
( \ _ _ _ . ( \ unpair . unpair \ y left' . pair y (branch x left' right) ) (minView left) )
101+
102+
# insertPrime :: Stream Int -> Set (Stream Int) -> Set (Stream Int)
103+
insertPrime = \ candidates . candidates
104+
\ prime _ .
105+
insert (map (mult prime) candidates)
106+
107+
# adjust :: Int -> Set (Stream Int) -> Set (Stream Int)
108+
adjust = \ x table .
109+
( \ unpair . unpair
110+
\ uncons table' . uncons
111+
\ n ns .
112+
EQ n x
113+
table
114+
(adjust x (insert ns table'))
115+
)
116+
(minView table)
117+
118+
# sieve :: Set (Stream Int) -> Stream Int -> Stream Int
119+
sieve = \ table xxs . xxs
120+
\ x xs .
121+
( \ uncons . uncons
122+
\ n _ .
123+
EQ n x
124+
(cons x (sieve (insertPrime xxs table) xs))
125+
(sieve (adjust x table) xs)
126+
)
127+
(findMin table)
128+
129+
# firstSieve :: Stream Int -> Stream Int
130+
firstSieve = \ xxs . xxs
131+
\ x xs .
132+
cons x (sieve (insertPrime xxs empty) xs)
133+
134+
# primes :: Stream Int
135+
primes = cons 2 (firstSieve (iterate (plus 2) 3))

‎tests/prime-sieve/solution.txt‎

Lines changed: 69 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -3,36 +3,80 @@
33
# primes
44
# according to The Real Sieve of Erathosthenes
55

6-
# B :: (b -> c) -> (a -> b) -> (a -> c)
7-
B = \ f g x . f (g x)
6+
#import Combinators.lc
87

9-
# data Int :: Zero | Succ Int
8+
B = \ f g x . f (g x)
9+
C = \ f x y . f y x
10+
I = \ x . x
11+
K = \ x _ . x
12+
KI = \ _ x . x
13+
M = \ x . x x
14+
S = \ f g x . f x (g x)
15+
T = \ x f . f x
16+
V = \ x y f . f x y
17+
W = \ f x . f x x
18+
Y = \ f . ( \ x . f (x x) ) ( \ x . f (x x) )
19+
Z = \ f . ( \ x . f \ y . x x y ) ( \ x . f \ y . x x y )
1020

11-
# succ :: Int -> Int
12-
succ = \ n . \ zero succ . succ n
21+
#import Ordering.lc
1322

14-
# plus :: Int -> Int -> Int
15-
plus = \ m n . n m (B succ (plus m))
23+
LT = \ lt eq gt . lt
24+
EQ = \ lt eq gt . eq
25+
GT = \ lt eq gt . gt
1626

17-
# mult :: Int -> Int -> Int
18-
mult = \ m n . n n (B (plus m) (mult m))
27+
# import Booleans.lc
1928

20-
# minus :: Int -> Int -> Int
21-
minus = \ m n . m m (B (n m) minus)
29+
False = \ false true . false
30+
True = \ false true . true
2231

23-
# data Bool :: False | True
32+
# data Number = End | Even Number | Odd Number
2433

25-
# false :: Bool
26-
false = \ false true . false
34+
# zero :: Int
35+
zero = \ end even odd . end
2736

28-
# true :: Bool
29-
true = \ false true . true
37+
# shiftR0,shiftR1 :: Int -> Int
38+
shiftR0 = \ n . \ end even odd . even n # mind that a shiftR in LE is a multiplication
39+
shiftR1 = \ n . \ end even odd . odd n # mind that a shiftR in LE is a multiplication
3040

3141
# isZero :: Int -> Bool
32-
isZero = \ n . n true ( \ n-1 . false )
33-
34-
# EQ :: Int -> Int -> Bool
35-
EQ = \ m n . m (isZero n) (B (n false) EQ)
42+
isZero = \ n . n True (K False) (K False)
43+
44+
# unpad :: Int -> Int
45+
unpad = \ n . n zero ( \ z . ( \ unpadZ . isZero unpadZ (shiftR0 unpadZ) zero ) (unpad z) ) (B shiftR1 unpad)
46+
47+
# succ,pred :: Int -> Int
48+
succ = \ n . n (shiftR1 zero) shiftR1 (B shiftR0 succ)
49+
go = \ prefix n . n zero
50+
(go (B prefix shiftR1))
51+
( \ z . z (prefix z) (K (prefix (shiftR0 z))) (K (prefix (shiftR0 z))) )
52+
pred = go I
53+
54+
# compare :: Int -> Int -> Ordering
55+
compare = \ m n . m (n EQ (K LT) (K LT))
56+
( \ zm . n GT (compare zm) ( \ zn . compare zm zn LT LT GT ) )
57+
( \ zm . n GT ( \ zn . compare zm zn LT GT GT ) (compare zm) )
58+
# eq,gt :: Int -> Int -> Bool
59+
eq = \ m n . compare m n False True False
60+
gt = \ m n . compare m n False False True
61+
62+
# plus,mult,minus :: Int -> Int -> Int
63+
plus = \ m n . m n
64+
( \ zm . n (shiftR0 zm) (B shiftR0 (plus zm)) (B shiftR1 (plus zm)) )
65+
( \ zm . n (shiftR1 zm) (B shiftR1 (plus zm)) (B shiftR0 (B succ (plus zm))) )
66+
67+
mult = \ m n . m m
68+
( \ zm . n n
69+
( \ zn . shiftR0 (shiftR0 (mult zm zn)) )
70+
( \ zn . shiftR0 (mult zm (shiftR1 zn)) )
71+
)
72+
( \ zm . n n
73+
( \ zn . shiftR0 (mult (shiftR1 zm) zn) )
74+
( \ zn . plus (shiftR1 zn) (shiftR0 (mult zm (shiftR1 zn))) )
75+
)
76+
unsafeMinus = \ m n . m zero
77+
( \ zm . n (shiftR0 zm) (B shiftR0 (unsafeMinus zm)) (B shiftR1 (B pred (unsafeMinus zm))) )
78+
( \ zm . n (shiftR1 zm) (B shiftR1 (unsafeMinus zm)) (B shiftR0 (unsafeMinus zm)) )
79+
minus = \ m n . gt m n zero (unpad (unsafeMinus m n)) # needs explicit unpad or will litter padding
3680

3781
# data Pair a b :: Pair a b
3882

@@ -62,12 +106,8 @@ map = \ fn xs . xs ( \ x xs . cons (fn x) (map fn xs) )
62106
# iterate :: (a -> a) -> a -> Stream a
63107
iterate = \ fn x . cons x (iterate fn (fn x))
64108

65-
# LE :: Int -> Int -> Bool
66-
# LE = \ m n . isZero (minus m n)
67-
# LE = \ m n . m true (B (n false) LE) # probably equal performance
68-
69-
# LE :: Stream Int -> Stream Int -> Bool
70-
LE = \ m n . isZero (minus (head m) (head n)) # no need to order on subsequent elements
109+
# le :: Stream a -> Stream a -> Bool
110+
le = \ m n . compare (head m) (head n) True True False
71111

72112
# data Set a = Nil | Branch a (Set a) (Set a)
73113

@@ -82,7 +122,7 @@ insert = \ x set .
82122
set
83123
(branch x empty empty)
84124
( \ y left right .
85-
LE x y
125+
le x y
86126
(branch y left (insert x right))
87127
(branch y (insert x left) right)
88128
)
@@ -109,7 +149,7 @@ adjust = \ x table .
109149
( \ unpair . unpair
110150
\ uncons table' . uncons
111151
\ n ns .
112-
EQ n x
152+
eq n x
113153
table
114154
(adjust x (insert ns table'))
115155
)
@@ -120,7 +160,7 @@ sieve = \ table xxs . xxs
120160
\ x xs .
121161
( \ uncons . uncons
122162
\ n _ .
123-
EQ n x
163+
eq n x
124164
(cons x (sieve (insertPrime xxs table) xs))
125165
(sieve (adjust x table) xs)
126166
)

‎tests/prime-sieve/test.js‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ const {assert} = chai;
44

55
const LC = require("../../src/lambda-calculus.js");
66
LC.config.purity = "LetRec";
7-
LC.config.numEncoding = "Scott";
7+
LC.config.numEncoding = "BinaryScott";
88
LC.config.verbosity = "Concise";
99

1010
const {primes} = LC.compile();
@@ -19,5 +19,12 @@ it("fixed tests: primes", function() {
1919
assert.equal( head(tail(primes)), 3 );
2020
assert.equal( head(tail(tail(primes))), 5 );
2121
assert.equal( head(tail(tail(tail(primes)))), 7 );
22-
assert.deepEqual( take(10)(primes).map(toInt), [2,3,5,7,11,13,17,19,23,29] );
22+
assert.deepEqual( take(100)(primes).map(toInt), [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71
23+
,73,79,83,89,97,101,103,107,109,113,127,131,137,139,149
24+
,151,157,163,167,173,179,181,191,193,197,199,211,223,227
25+
,229,233,239,241,251,257,263,269,271,277,281,283,293,307
26+
,311,313,317,331,337,347,349,353,359,367,373,379,383,389
27+
,397,401,409,419,421,431,433,439,443,449,457,461,463,467
28+
,479,487,491,499,503,509,521,523,541
29+
] );
2330
});

0 commit comments

Comments
 (0)