diff options
Diffstat (limited to 'lisp/ouat/examples.lisp')
| -rw-r--r-- | lisp/ouat/examples.lisp | 197 |
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))))))) |