Initial git commit.

1 files changed, 197 insertions, 0 deletions

diff --git a/lisp/ouat/examples.lisp b/lisp/ouat/examples.lisp
new file mode 100644
index 0000000..cb319cd
--- /dev/null
+++ b/lisp/ouat/examples.lisp
@@ -0,0 +1,197 @@
+(in-package :ouat)
+
+(defun jqxz+1-stems ()
+  (let ((racks-that-bingo-through-jqxz
+         (unique
+          (loop
+             for big-tile across "JQXZ"
+             for ana-pattern = (format nil "~a???????" big-tile)
+             append (steal-tiles ana-pattern))))
+        (jqxz+1-stems nil))
+    (dolist (rack racks-that-bingo-through-jqxz)
+      (let ((ana-pattern (format nil "~a?" rack)))
+        (multiple-value-bind (words blanks)
+            (anagram-stem ana-pattern)
+          (when (and (= 2 (length words))
+                     (string/= (first blanks) 
+                               (second blanks)))
+            (push rack jqxz+1-stems)))))
+    jqxz+1-stems))  
+
+#+nil
+(defun woadwage-bingos (n)
+  (let ((bag (coerce *english-scrabble-bag* 'list)))
+    (labels ((draw-random-rack ()
+               (coerce (subseq (shuffle bag) 0 7) 'string)))
+      (loop
+         for i below n
+         for rack = (draw-random-rack)
+         count (woadwage rack)))))
+
+(defun chewscore (word1 word2)
+  (labels ((uniq-pairs (word)
+             (unique
+              (sort 
+               (loop
+                  for idx below (1- (length word))
+                  collect (subseq word idx (+ 2 idx)))
+               'string<))))
+  (let* ((pairs1 (uniq-pairs word1))
+         (pairs2 (uniq-pairs word2)))
+    (- (length (union pairs1 pairs2 :test 'string=))
+       (max (length pairs1) (length pairs2))))))
+
+(defun wordmath ()
+  (declare (optimize (debug 3)))
+  (let ((twl-alphas (make-hash-table :test 'equal))
+        (csw-alphas (make-hash-table :test 'equal)))
+    (labels ((alpha (word)
+               (sort (coerce word 'list) 'char<))
+             (minus-one (word+already-subtracted)
+               #+nil
+               (format t "(minus-one ~a)~%" word+already-subtracted)
+               (loop
+                  with word = (first word+already-subtracted)
+                  with already-subtracted = (rest word+already-subtracted)
+                  with used-letters = (make-hash-table)
+                  for idx below (length word)
+                  for letter = (elt word idx)
+                  for before = (subseq word 0 idx)
+                  for after = (subseq word (1+ idx))
+                  for alpha = (coerce 
+                               (alpha (concatenate 'string before after))
+                               'string)
+                  unless (gethash letter used-letters) do
+                    #+nil
+                    (format t "alpha: ~a~%" alpha)
+                    (setf (gethash letter used-letters) t)
+                    collect (cons alpha (cons letter already-subtracted)))) 
+             (best-subword (word num-missing)
+               #+nil
+               (format t "word: ~a~%" word)
+               (loop
+                  with sub-alphas = (list (list word))
+                  repeat num-missing
+                  do
+                    (setf sub-alphas
+                          (unique (apply 'append (mapcar #'minus-one sub-alphas))))
+                    #+nil
+                    (format t "sub-alphas: ~a~%" sub-alphas)
+                  finally
+                    (loop
+                       with best-score = MOST-NEGATIVE-FIXNUM
+                       with best = nil
+                       for (alpha . letters) in sub-alphas
+                       for a = (coerce alpha 'list)
+                       for twl = (gethash a twl-alphas)
+                       for csw = (gethash a csw-alphas)
+                       ;;do (format t "twl: ~a csw: ~a~%" twl csw)
+                       when (and twl (= 1 (length csw))) do
+                         (let* ((subword (first csw))
+                                (score (chewscore subword word)))
+                           #+nil
+                           (format t "subword: ~a letters: ~a score: ~a~%" subword letters score)
+                           (when (> score best-score)
+                             (setf best-score score
+                                   best (cons subword letters))))
+                       finally
+                         (when best
+                           #+nil
+                           (format t "BEST: ~a~%" best)
+                           (return-from best-subword
+                             (values (first best) (rest best) best-score)))))))
+      (do-file-lines (word (string-append *data-directory* "twl.txt"))
+        (when (<= 5 (length word) 7)
+          (push word (gethash (alpha word) twl-alphas))))
+      (do-file-lines (word (string-append *data-directory* "csw.txt"))
+        (when (<= 5 (length word) 7)
+          (push word (gethash (alpha word) csw-alphas))))
+      (do-file-lines (word (string-append *data-directory*
+                                          "csw-single-sevens.txt"
+                                          #+nil
+                                          "csw-single-eights.txt"))
+        (multiple-value-bind (subword letters score)
+            (best-subword word 1)
+          #+nil
+          (format t "subword: ~a~%" subword)
+          (if (and score (> score 2))
+              (format t "~a + ~a = ~a~%" subword (first letters) word)
+              (multiple-value-bind (subword2 letters2 score2)
+                  (best-subword word 2)
+                #+nil
+                (format t "subword: ~a~%" subword)
+                (when (and score2 (> score2 2))
+                  (format t "~a + ~a = ~a~%"
+                          subword2
+                          (concatenate 'string (sort letters2 'char<))
+                          word)))))))))
+
+(defun csw-hook-worksheet (length words-shown hooks-shown columns hidden)
+  (declare (optimize (debug 3)))
+  (let ((front (make-hash-table :test 'equal))
+        (back (make-hash-table :test 'equal))
+        (words nil)
+        (csw (make-hash-table :test 'equal))
+        (twl (make-hash-table :test 'equal))
+        (hook-cols (floor (- columns length 3) 2)))
+    (do-file-lines (word (string-append *data-directory* "twl.txt"))
+      (setf (gethash word twl) t))
+    (do-file-lines (word (string-append *data-directory* "csw.txt"))
+      (when (and (= length (length word))
+                 (not (gethash word twl)))
+        (push word words))
+      (setf (gethash word csw) t))
+    (setf words (nreverse words))
+    (do-file-lines (word (string-append *data-directory* "csw.txt"))
+      (when (= (1+ length) (length word))
+        (let ((left-substr (subseq word 0 length))
+              (left-letter (elt word 0))
+              (right-substr (subseq word 1))
+              (right-letter (elt word length)))
+          (when (gethash right-substr csw)
+            (push (if (gethash word twl)
+                      (char-downcase left-letter)
+                      left-letter)
+                  (gethash right-substr front)))
+          (when (gethash left-substr csw)
+            (push (if (gethash word twl)
+                      (char-downcase right-letter)
+                      right-letter)
+                  (gethash left-substr back))))))
+    (dolist (word words)
+      (labels ((maybe-hide (letter)
+                 (case hooks-shown
+                   (:all letter)
+                   (:twl (if (char= letter (char-downcase letter))
+                             letter
+                             #\_))
+                   (nil #\_))))
+        (let* ((raw-fronts (nreverse (gethash word front)))
+               (fronts (coerce (mapcar #'maybe-hide raw-fronts) 'string))
+               (front-rows (ceiling (length fronts) hook-cols))
+               (raw-backs (nreverse (gethash word back)))
+               (backs (coerce (mapcar #'maybe-hide raw-backs) 'string))
+               (back-rows (ceiling (length backs) hook-cols)))
+          (loop
+             for row below (max 1 front-rows back-rows)
+             for start = (* row hook-cols)
+             for end = (+ start hook-cols)
+             for front-row = (subseq fronts
+                                     (min start (length fronts))
+                                     (min end (length fronts)))
+             for back-row = (subseq backs
+                                    (min start (length backs))
+                                    (min end (length backs)))
+             for padding = (- hook-cols (length front-row))
+             do
+               (loop repeat padding do (format t " "))
+               (format t "~a " front-row)
+               (if (zerop row)
+                   (if words-shown
+                       (format t "~a#" word)
+                       (progn
+                         (format t "~a" (subseq word 0 (- length hidden)))
+                         (loop repeat hidden do (format t "_"))
+                         (format t "#")))
+                   (loop repeat (1+ length) do (format t " ")))
+               (format t " ~a~%" back-row)))))))