git.iko.soy/urbit.org
on master help sign in
Create scheme.md
222f8d2Kohányi Róbert
docs/nock/implementations/scheme.mdnew file+128
compare with master
unifiedsplit
@@ -0,0 +1,128 @@
1+---
2+navhome: /docs
3+title: Scheme
4+sort: 8
5+next: true
6+---
7+
8+# Groovy
9+
10+From [Kohányi Róbert](https://github.com/kohanyirobert/snock/blob/master/snock.ss):
11+
12+```
13+(import (rnrs (6)))
14+
15+(define (i a) a)
16+
17+(define (n a r)
18+ (cond
19+ ((list? a)
20+ (let ((l (length a)))
21+ (cond
22+ ((equal? l 0) (raise 1))
23+ ((equal? l 1) (r (car a)))
24+ (else
25+ (let ((t (cond
26+ ((equal? l 2) (cadr a))
27+ (else (cdr a)))))
28+ (n (car a)
29+ (lambda (p) (n t
30+ (lambda (q) (r (cons p q)))))))))))
31+ ((fixnum? a) (r a))
32+ (else (raise 2))))
33+
34+(define (wut a)
35+ (cond
36+ ((fixnum? a) 1)
37+ (else 0)))
38+
39+(define (lus a)
40+ (cond
41+ ((equal? (wut a) 0) (raise 3))
42+ (else (+ 1 a))))
43+
44+(define (tis a)
45+ (cond
46+ ((equal? (wut a) 1) (raise 4))
47+ ((equal? (car a) (cdr a)) 0)
48+ (else 1)))
49+
50+(define (fas a r)
51+ (cond
52+ ((equal? (wut a) 1) (raise 5))
53+ (else
54+ (let ((h (car a))
55+ (t (cdr a)))
56+ (cond
57+ ((not (fixnum? h)) (raise 6))
58+ ((equal? h 0) (raise 7))
59+ ((equal? h 1) (r t))
60+ ((fixnum? t) (raise 8))
61+ ((equal? h 2) (r (car t)))
62+ ((equal? h 3) (r (cdr t)))
63+ (else
64+ (fas (cons (div h 2) t)
65+ (lambda (p) (fas (cons (+ 2 (mod h 2)) p)
66+ (lambda (q) (r q)))))))))))
67+
68+(define (tar a r)
69+ (cond
70+ ((equal? (wut a) 1) (raise 9))
71+ (else
72+ (let ((s (car a))
73+ (f (cdr a)))
74+ (cond
75+ ((equal? (wut f) 1) (raise 10))
76+ (else
77+ (let ((o (car f))
78+ (v (cdr f)))
79+ (cond
80+ ((equal? (wut o) 0) (tar (cons s o)
81+ (lambda (p) (tar (cons s v)
82+ (lambda (q) (r (cons p q)))))))
83+ ((equal? o 0) (r (fas (cons v s) i)))
84+ ((equal? o 1) (r v))
85+ ((equal? o 3) (tar (cons s v)
86+ (lambda (p) (r (wut p)))))
87+ ((equal? o 4) (tar (cons s v)
88+ (lambda (p) (r (lus p)))))
89+ ((equal? o 5) (tar (cons s v)
90+ (lambda (p) (r (tis p)))))
91+ ((equal? (wut v) 1) (raise 11))
92+ (else
93+ (let ((x (car v))
94+ (y (cdr v)))
95+ (cond
96+ ((equal? o 2) (tar (cons s x)
97+ (lambda (p) (tar (cons s y)
98+ (lambda (q) (tar (cons p q)
99+ (lambda (u) (r u))))))))
100+ ((equal? o 7) (tar (n (list (list s) 2 (list x) 1 (list y)) i)
101+ (lambda (p) (r p))))
102+ ((equal? o 8) (tar (n (list (list s) 7 (list (list 7 (list 0 1) (list x)) 0 1) (list y)) i)
103+ (lambda (p) (r p))))
104+ ((equal? o 9) (tar (n (list (list s) 7 (list y) 2 (list 0 1) 0 (list x)) i)
105+ (lambda (p) (r p))))
106+ ((equal? o 10) (cond
107+ ((equal? (wut x) 1) (tar (cons s y)
108+ (lambda (p) (r p))))
109+ (else (tar (n (list (list s) 8 (list (cdr x)) 7 (list 0 3) (list y)) i)
110+ (lambda (p) (r p))))))
111+ ((equal? (wut y) 1) (raise 12))
112+ ((equal? o 6) (tar (n (list
113+ (list s)
114+ 2
115+ (list 0 1)
116+ 2
117+ (list 1 (list (car y)) (list (cdr y)))
118+ (list 1 0)
119+ 2
120+ (list 1 2 3)
121+ (list 1 0)
122+ 4
123+ 4
124+ (list x))
125+ i)
126+ (lambda (p) (r p))))
127+ (else (raise 13)))))))))))))
128+```