initial commit HEAD main

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))