git.iko.soy/urbit.org
on 77a6721 help sign in
urbit.org/docs/nock/implementations/scheme.md
128 lines 4.6 kB history raw
1---
2navhome: /docs
3title: Scheme
4sort: 8
5next: true
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```