anki-cards.lsp

(defvar *vowel-first* t)
(defvar *twl98* (make-hash-table :test 'equal))
(defvar *twl06* (make-hash-table :test 'equal))
(defvar *twl14* (make-hash-table :test 'equal))
(defvar *csw12* (make-hash-table :test 'equal))
(defvar *csw15* (make-hash-table :test 'equal))
(defvar *pbs* (make-hash-table :test 'equal))

(defun load-twl98 ()
  (load-dict "/Users/john/scrabble/twl98.txt" *twl98*))
(defun load-twl06 ()
  (load-dict "/Users/john/scrabble/twl06.txt" *twl06*))
(defun load-twl14 ()
  (load-dict "/Users/john/scrabble/twl14.txt" *twl14*))
(defun load-csw12 ()
  (load-dict "/Users/john/scrabble/csw12.txt" *csw12*))
(defun load-csw15 ()
  (load-dict "/Users/john/scrabble/csw15.txt" *csw15*))
(defun load-ranked-pbs ()
  (setf *pbs* (load-pbs "/Users/john/scrabble/ranked-pbs.txt")))

(defstruct word-info
  word
  in-older
  in-older-smaller
  in-smaller
  pb
  front-hooks
  back-hooks)

(defun load-dict (file dict)
  (with-open-file (stream file)
    (loop for word = (read-line stream nil) while word do
	 (setf (gethash word dict) t))))

(defun split (string del) 
  (loop for i = 0 then (1+ j)
     as j = (position del string :start i)
     collect (subseq string i j)
     while j))

(defun load-pbs (file)
  (let ((pbs (make-hash-table :test 'equal)))
    (with-open-file (stream file)
      (loop
	 for line = (read-line stream nil) while line
	 for (pb-string word) = (split line #\Space) do
	   (setf (gethash word pbs) (parse-integer pb-string))))
    pbs))

(defun alphagram (word)
  (coerce (sort (coerce word 'list) 'string<) 'string))

(defun get-words (dict older older-smaller smaller oldest-small pbs length min-ana max-ana)
  (labels ((pb-sum (words)
	     (loop for word in words summing (gethash (word-info-word word) pbs 0)))
	   (new (word)
	     (not (gethash (word-info-word word) older)))
	   (new-or-foreign (word)
	     (or (not (gethash (word-info-word word) oldest-small))
		 (not (gethash (word-info-word word) older-smaller))))
	   (changed (word)
	     (or (not (word-info-in-older word))
		 (not (eq (word-info-in-smaller word)
			  (word-info-in-older-smaller word)))))
	   (changed-hook (word)
	     (or (some #'changed (word-info-back-hooks word))
		 (some #'changed (word-info-front-hooks word))))
	   (find-front-hooks (word)
	     (loop
		for letter across "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		for hook-word = (concatenate 'string (list letter) word)
		when (gethash hook-word dict) collect
		  (make-word-info :word letter
				  :in-older (gethash hook-word older)
				  :in-older-smaller (gethash hook-word older-smaller)
				  :in-smaller (gethash hook-word smaller))))
	   (find-back-hooks (word)
	     (loop
		for letter across "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		for hook-word = (concatenate 'string word (list letter))
		when (gethash hook-word dict) collect
		  (make-word-info :word letter
				  :in-older (gethash hook-word older)  
				  :in-older-smaller (gethash hook-word older-smaller)  
				  :in-smaller (gethash hook-word smaller)))))
    (let ((words (make-hash-table :test 'equal)))
      (loop
	 for word being the hash-keys of dict
	 when (= (length word) length) do
	   (let ((alpha (alphagram word))
		 (in-older (gethash word older))
		 (in-older-smaller (gethash word older-smaller))
		 (in-smaller (gethash word smaller))
		 (word-info (make-word-info)))
	     (setf (word-info-word word-info) word)
	     (setf (word-info-in-older word-info) in-older)
	     (setf (word-info-in-older-smaller word-info) in-older-smaller)
	     (setf (word-info-in-smaller word-info) in-smaller)
	     (setf (word-info-front-hooks word-info)
		   (find-front-hooks word))
	     (setf (word-info-back-hooks word-info)
		   (find-back-hooks word))
	     (push word-info (gethash alpha words))))
      (sort (loop
	       for alpha being the hash-keys of words
	       for alpha-words being the hash-values of words
	       for pb = (pb-sum alpha-words)
	       when (and (<= min-ana (length alpha-words) max-ana)
			 (or t #+nil
			     (some #'new alpha-words)
			     #+nil
			     (some #'new-or-foreign alpha-words)
			     #+nil
			     (some #'changed alpha-words)
			     #+nil
			     (some #'changed-hook alpha-words)))
	       collect (cons (cons pb alpha) alpha-words))
	    #'> :key #'caar))))

(defun tagged-word (word)
  (let ((tags nil))
    (if (word-info-in-older word)
	(if (and (word-info-in-smaller word)
		 (not (word-info-in-older-smaller word)))
	    (push "o" tags))
      (push "b" tags))
    (unless (word-info-in-smaller word)
      (push "r" tags))
    (labels ((open-tag (tag)
	       (format nil "<~a>" tag))
	     (close-tag (tag)
	       (format nil "</~a>" tag)))
      (apply #'concatenate 'string
	     (append (mapcar #'open-tag tags)
		     (list (format nil "~a" (word-info-word word)))
		     (mapcar #'close-tag (reverse tags)))))))

(defun tagged-hooks (hooks)
  (and hooks (append (list "<sup>")
		     (mapcar #'tagged-word hooks)
		     (list "</sup>"))))
	
(defun word-line (word)
  (apply #'concatenate 'string
	 (append
	  (tagged-hooks (word-info-front-hooks word))
	  (list " " (tagged-word word) " ")
	  (tagged-hooks (word-info-back-hooks word))
	  (list "<br>"))))

(defun pretty-alphagram (alpha)
  (if *vowel-first*
      (let ((consonants nil)
	    (vowels nil))
	(loop
	   for x across alpha
	   for xlist = (format nil "~A" x) do
	     (if (or (eq x #\A) (eq x #\E) (eq x #\I) (eq x #\O) (eq x #\U))
		 (push xlist vowels)
		 (push xlist consonants)))
	(apply #'concatenate 'string
	       (append (reverse vowels) (reverse consonants))))
      alpha))

(defun make-card (alpha words)
  (apply #'concatenate 'string
	 (append (list (pretty-alphagram alpha) "; ")
		 (loop for word in (sort words #'string<' :key #'word-info-word)
		    collecting
		      (word-line word)))))

(defun make-cards (words file)
  (with-open-file (stream file
    :direction :output
    :if-exists :overwrite
    :if-does-not-exist :create)
    (loop
       for ((pb . alpha) . alpha-words) in words
       for card = (make-card alpha alpha-words) do
	 (write-line card stream))))