1 files changed, 193 insertions, 0 deletions
diff --git a/rusle.scm b/rusle.scm
new file mode 100644
index 0000000..7f4e31c
--- /dev/null
+++ b/rusle.scm
@@ -0,0 +1,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))
|
