diff options
| -rw-r--r-- | rusle.scm | 193 |
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)) |