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