blob: 7f4e31cdbe1b226206c104cebf810733cce7b2b2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
;; rusle - wordle clone in scheme macros
;; to play: (play (R U L E S))
;; X: letter in correct spot
;; +: letter in wrong spot
;; -: letter not present
;; scroll to bottom for spoilers
;; using extradimensional manipulation techniques we can fit several pigeons
;; into a single hole
(define-syntax fit-pigeon
(syntax-rules ()
((fit-pigeon (pigeon ...)
(hole ...) (full ...)
(outer-hole ...) (outer-full ...)
(next next* ...))
(next (pigeon ...) (outer-hole ...) (outer-full ... (full ...)) next* ...))))
(define-syntax send-pigeons
(syntax-rules ()
((send-pigeons () () holes rest ...)
holes)))
;; (continue* (values) (upcoming-symbols) (past-symbols)
(define-syntax continue*
(syntax-rules (<> ->)
((continue* () (hole ...) (full ...) (next next* ...))
(next () () (full ... hole ...) next* ...))
((continue* (pigeon ...) () (full ...) (next next* ...))
(next (pigeon ...) () (full ...) next* ...))
((continue* (pigeon pigeon* ...) (<> hole ...) (full ...) next)
(continue* (pigeon* ...) (hole ...) (full ... pigeon) next))
((continue* (pigeon ...) (-> (hole ...) hole* ...) (full ...) next)
(continue* (pigeon ...) (hole ...) ()
(fit-pigeon (hole* ...) (full ...) (continue* next))))
((continue* (pigeon ...) (hole hole* ...) (full ...) next)
(continue* (pigeon ...) (hole* ...) (full ... hole) next))))
;; hellish continuation passing type guy
;; (continue (quote <>) 4) -> (quote 4)
;; (continue (quote -> (<> <>)) foo bar) -> (quote (foo bar))
(define-syntax continue
(syntax-rules (<> ->)
((continue holes pigeons ...)
(continue* (pigeons ...) holes () (send-pigeons)))))
;; (alphabetize* list-of-symbols next-replacement output next
;; (alphabetize* (W O R D L E) (chk chk) () (continuation))
(define-syntax alphabetize*
(syntax-rules ()
((alphabetize* () replacement output next)
(continue next output))
((alphabetize* ((sym ...) syms ...) replacement (output ...) next)
(alphabetize* (syms ...) replacement (output ... (sym ...)) next))
((alphabetize* (sym syms ...) (replacement ...) (output ...) next)
(letrec-syntax
((replace
;; replace (sym sym sym) (outsym outsym) next
(syntax-rules ooo (sym)
((replace () outsyms next*)
(continue next* outsyms))
((replace (sym syms* ooo) (outsyms ooo) next*)
(replace (syms* ooo) (outsyms ooo (replacement ...)) next*))
((replace (sym* syms* ooo) (outsyms ooo) next*)
(replace (syms* ooo) (outsyms ooo sym*) next*)))))
(replace (syms ...)
()
(alphabetize* <>
(replacement ... chk)
(output ... (replacement ...))
next))))))
;; turns an opaque list of letters into a list of actually-manipulable
;; symbols (just lists of nonsense data where the length of the list
;; determines what it is)
;; (alphabetize (P E N I S O U I J A) next)
(define-syntax alphabetize
(syntax-rules ()
((alphabetize syms next)
(alphabetize* syms () () next))))
(define-syntax zip*
(syntax-rules ()
((zip* () () output next)
(continue next output))
((zip* (a a* ...) (b b* ...) (output ...) next)
(zip* (a* ...) (b* ...) (output ... a b) next))))
(define-syntax zip
(syntax-rules ()
((zip a b next)
(zip* a b () next))))
(define-syntax unzip*
(syntax-rules ()
((unzip* () a* b* next)
(continue next a* b*))
((unzip* (a b rest ...) (a* ...) (b* ...) next)
(unzip* (rest ...) (a* ... a) (b* ... b) next))))
(define-syntax unzip
(syntax-rules ()
((unzip syms next)
(unzip* syms () () next))))
(define-syntax sym-equal
(syntax-rules ()
;; if lists are contained within we bail
((sym-equal ((thing ...) thing* ...) whatever yes no)
no)
((sym-equal whatever ((thing ...) thing* ...) yes no)
no)
((sym-equal (a a* ...) (b b* ...) yes no)
(sym-equal (a* ...) (b* ...) yes no))
((sym-equal (a a* ...) () yes no)
no)
((sym-equal () (b b* ...) yes no)
no)
((sym-equal () () yes no)
yes)))
(define-syntax greens*
(syntax-rules ()
((greens* () () secret guess next)
(continue next secret guess))
((greens* (key key* ...) (hole hole* ...) (secret ...) (guess ...) next)
(sym-equal key
hole
(greens* (key* ...) (hole* ...)
(secret ... ((X))) (guess ... ((X))) next)
(greens* (key* ...) (hole* ...)
(secret ... key) (guess ... hole) next)))))
(define-syntax greens
(syntax-rules ()
((greens key hole next)
(greens* key hole () () next))))
(define-syntax oranges*
(syntax-rules ()
((oranges* () () secret guess next)
(continue next guess))
((oranges* (key key* ...) (hole hole* ...) (secret ...) (guess ...) next)
(sym-equal key
hole
(oranges* (key* ...) (guess ... ((+)) hole* ...)
(secret ... ((+))) ()
next)
(oranges* (key key* ...) (hole* ...)
(secret ...) (guess ... hole)
next)))
((oranges* (key key* ...) () (secret ...) (guess ...) next)
(oranges* (key* ...) (guess ...) (secret ... key) () next))
((oranges* () (hole ...) (secret ...) (guess ...) next)
(continue next (guess ... hole ...)))))
(define-syntax oranges
(syntax-rules ()
((oranges key hole next)
(oranges* key hole () () next))))
(define-syntax grays*
(syntax-rules ()
((grays* () guess next)
(continue next guess))
((grays* (((state)) hole ...) (guess ...) next)
(grays* (hole ...) (guess ... state) next))
((grays* (fail hole ...) (guess ...) next)
(grays* (hole ...) (guess ... -) next))))
(define-syntax grays
(syntax-rules ()
((grays guess next)
(grays* guess () next))))
(define-syntax compare
(syntax-rules ()
((make-guess secret guess next)
(zip secret guess
(alphabetize
<>
(unzip
<>
(greens <> <> (oranges <> <> (grays <> next)))))))))
(define-syntax make-game
(syntax-rules ()
((make-game name word)
(define-syntax name
(syntax-rules ()
((name guess)
(compare word guess (quote <>))))))))
(make-game play (F O L L Y))
|
