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