git.iko.soy/urbit.org
on c19bc7a help sign in
urbit.org/docs/tutorials/nock/implementations/scheme.udon
128 lines 4.6 kB history raw
1:- :~ navhome/'/docs/'
2 next/'true'
3 sort/'8'
4 title/'Scheme'
5 ==
6;>
8# Scheme
10From [Kohányi Róbert](https://github.com/kohanyirobert/snock/blob/master/snock.ss):
12```
13(import (rnrs (6)))
15(define (i a) a)
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))))
34(define (wut a)
35 (cond
36 ((fixnum? a) 1)
37 (else 0)))
39(define (lus a)
40 (cond
41 ((equal? (wut a) 0) (raise 3))
42 (else (+ 1 a))))
44(define (tis a)
45 (cond
46 ((equal? (wut a) 1) (raise 4))
47 ((equal? (car a) (cdr a)) 0)
48 (else 1)))
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)))))))))))
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```