(in-package :ouat)

(defstruct layout
  height
  width
  center-row
  center-col
  letter-muls
  word-muls)

(defun new-symmetric-square-layout (eighth)
  (let* ((center (1- (length eighth)))
         (size (+ 1 center center))
         (letter-muls (make-array `(,size ,size) :initial-element 1))
         (word-muls (make-array `(,size ,size) :initial-element 1)))
    (loop
       for row-list in eighth
       for row from 0
       do (loop
             with squares = (string-tokens row-list)
             for square in squares
             for col from 0
             for mul = (parse-integer square :junk-allowed t)
             for array = (case (elt square 1)
                           (#\L letter-muls)
                           (#\W word-muls))
             when (and mul array)
             do (setf (aref array row col) mul
                      (aref array col row) mul
                      (aref array (- size row 1) col) mul
                      (aref array row (- size col 1)) mul
                      (aref array (- size row 1) (- size col 1)) mul
                      (aref array (- size col 1) (- size row 1)) mul
                      (aref array (- size col 1) row) mul
                      (aref array col (- size row 1)) mul)))
    (make-layout :height size
                 :width size
                 :center-row center
                 :center-col center
                 :letter-muls letter-muls
                 :word-muls word-muls)))

(defstruct tile
  text
  blank-text
  quantity
  score
  type
  name)

(defun text-tile (text tiles)
  (loop
     for index fixnum from 1
     for tile across (subseq tiles 1) do
       (when (string= text (tile-text tile))
	 (return-from text-tile index))))

(defun tiles-blank (tiles)
  (loop
     for index fixnum from 1
     for tile across (subseq tiles 1) do
       (when (eq :BLANK (tile-type tile))
	 (return-from tiles-blank index))))
       
(defstruct board
  layout
  (empty-p t)
  blank-ps
  letters
  sq-infos
  nodes)

(defstruct sq-info
  h
  v)

(defstruct h/v
  cross
  score
  nodes
  scores
  positions)

(defun new-sq-info ()
  (make-sq-info :h (make-h/v) :v (make-h/v)))
     
(defun new-board (layout)
  (labels ((new-board-array (type initial-element)
             (make-array (list (layout-height layout)
                               (layout-width layout))
                          :element-type type 
                          :initial-element initial-element)))
    (let ((board
           (make-board :layout layout
                       :blank-ps (new-board-array 'boolean nil)
                       :letters (new-board-array 'fixnum +empty+)
                       :sq-infos (new-board-array t nil))))
      (dotimes (row (layout-height layout))
        (dotimes (col (layout-height layout))
          (setf (aref (board-sq-infos board) row col) (new-sq-info))))
      board)))

(defun mul-text (letter-mul word-mul letter-mul-texts word-mul-texts)
  (if (i< 1 letter-mul)
      (aref letter-mul-texts letter-mul)
      (aref word-mul-texts word-mul)))

(defun board-row-pretty-squares (board row tiles
                                 letter-mul-texts word-mul-texts)
  (loop
     with layout = (board-layout board)
     for col below (layout-width layout)
     for letter = (aref (board-letters board) row col)
     collect
       (if (iplusp letter)
           (let ((letter-tile (aref tiles letter)))
             (if (aref (board-blank-ps board) row col)
                 (tile-blank-text letter-tile)
                 (tile-text letter-tile)))
           (mul-text (aref (layout-letter-muls layout) row col)
                     (aref (layout-word-muls layout) row col)
                     letter-mul-texts word-mul-texts))))

(defun board-pretty-squares (board tiles letter-mul-texts
                             word-mul-texts)
  (loop
     with layout = (board-layout board)
     for row below (layout-height layout) collect
       (board-row-pretty-squares board row tiles letter-mul-texts
                                 word-mul-texts)))

(defun place-move (board move)
  (when (eq (move-action move) :place)
    (setf (board-empty-p board) nil)
    (loop
       with row = (move-start-row move)
       with col = (move-start-col move)
       for letter across (move-word move)
       for blank-p across (move-blank-ps move)
       for already-p across (move-already-on-board-ps move)
       unless already-p do
         (setf (aref (board-letters board) row col) letter
               (aref (board-blank-ps board) row col) blank-p)
       do (if (eq (move-direction move) :horizontal)
              (iincf col)
              (iincf row)))))

(defstruct rack
  capacity
  (tiles (make-array '(30) :element-type 'fixnum)
         :type (simple-array fixnum)))

(defun rack-texts (rack tiles)
  (loop
     for tile being the elements of (rack-tiles rack) collect
       (tile-text (aref tiles tile))))

(defun rack-sort (rack)
  (make-rack :capacity (rack-capacity rack)
             :tiles (sort (copy-seq (rack-tiles rack)) '<)))

(defun rack-size (rack)
  (loop
     with num-tiles = 0
     for tile across (rack-tiles rack)
     when (iplusp tile)
     do (iincf num-tiles)
     finally (return (the fixnum num-tiles))))

(defstruct move
  action ; (:place :exchange :pass :deadwood :time-penalty)
  challenged-phony-p
  bingo-p
  score
  static-equity
  simmed-equity
  win%
  
  direction ; (:horizontal :vertical)
  start-row
  start-col
  word
  blank-ps
  tiles
  already-on-board-ps)

(defun move-string (move tiles)
  (when (eq (move-action move) :place)
    (let* ((row (row2uv-row (move-start-row move)))
           (col (col2uv-col (move-start-col move)))
           (pos (if (eq :vertical (move-direction move))
                    (format nil "~a~a" col row)
                    (format nil "~a~a" row col)))
           (word (apply #'concatenate 
                        (cons
                         'string
                         (loop
                            for tile-id across (move-word move)
                            for tile = (aref tiles tile-id)  
                            for blank-p across (move-blank-ps move)
                            collect (if blank-p
                                        (tile-blank-text tile)
                                        (tile-text tile)))))))
      (format nil "~a ~a" pos word))))
    
(defstruct dawg
  nodes
  nth-child-letter-table
  letter2child-table)

(defstruct filldawg
  nodes)

(defun new-dawg (nodes)
  (let ((nth-child-table (make-array (* 32 (length nodes))
                                     :element-type '(unsigned-byte 8)))
        (letter2child-table (make-array (* 32 (length nodes))
                                        :element-type '(unsigned-byte 32))))
    (loop
       for node-idx from 0
       for node across nodes do
         (labels ((node-has-child (child-letter)
                    (logbitp child-letter node)))
           (loop
              with n = 0
              for letter below 26
              when (node-has-child letter) do
                (setf (aref letter2child-table (i+ (i* 32 node-idx) (i1+ letter)))
                      (i+ node-idx (node-letter-offset node letter)))
                (setf (aref nth-child-table (i+ (i* 32 node-idx) n)) (i1+ letter))
                (iincf n))))
    (make-dawg :nodes nodes
               :nth-child-letter-table nth-child-table
               :letter2child-table letter2child-table)))

(defstruct gaddag
  nodes)

(defstruct lexicon
  dawg
  filldawg)

(defstruct filldawg-node
  (data 0)
  (children nil))

(defun filldawg-node-letter (node)
  (logand (filldawg-node-data node) #.(i1- (iash 1 5))))

(defun set-filldawg-node-letter (node letter)
  (assert (typep letter '(integer 0 #.(i1- (iash 1 5)))))
  (setf (filldawg-node-data node)
        (logior (logand (filldawg-node-data node)
                          #.(ilognot (i1- (iash 1 5))))
                letter)))

(defun filldawg-node-terminal-p (node)
  (logbitp 5 (filldawg-node-data node)))

(defun set-filldawg-node-terminal-p (node terminal-p)
  (setf (logbitp 5 (filldawg-node-data node)) terminal-p))

(defun filldawg-node-idx (node)
  (ash (filldawg-node-data node) -6))

(defun set-filldawg-node-idx (node idx)
  (setf (filldawg-node-data node)
        (logior (logand (filldawg-node-data node)
                          #.(i1- (iash 1 6)))
                 (ash idx 6))))

(defun filldawg-node-child-which-has-letter (node letter)
  (find-if #'(lambda (child)
               (i= letter (filldawg-node-letter child)))
           (filldawg-node-children node)))

(defun filldawg-node-child-which-has-letter! (node letter)
  (or (filldawg-node-child-which-has-letter node letter)
      (first (push (make-filldawg-node :data letter)
                   (filldawg-node-children node)))))

(defun filldawg-push-suffix (suffix node)
  (set-filldawg-node-idx node 0)
  (let* ((letter (first suffix))
         (new-suffix (rest suffix)))
    (if suffix
        (filldawg-push-suffix
         new-suffix
         (filldawg-node-child-which-has-letter! node letter))
        (set-filldawg-node-terminal-p node t))))

(defun filldawg-push-word (word trie)
  (filldawg-push-suffix (coerce word 'list) trie))

(defun filldawg-sort-children (node)
  (setf (filldawg-node-children node)
        (sort (filldawg-node-children node)
              '< :key 'filldawg-node-letter))
  (dolist (child (filldawg-node-children node))
    (filldawg-sort-children child)))

(defun filldawg-node-child-bits (node)
  (let ((child-bits 0))
    (dolist (child (filldawg-node-children node))
      (setf (logbitp (filldawg-node-letter child) child-bits) t))
    child-bits))

(defun filldawg-node-bits (node)
  (let ((bits (filldawg-node-idx node)))
    (if (filldawg-node-terminal-p node)
        (logior bits (ash 1 28))
        bits)))

(defun filldawg-node-whole-word-p (node)
  (logbitp 28 node))

(defun filldawg-number-trie (node)
  (let ((index 0))
    (labels ((number-subtrie (node)
               (if (filldawg-node-children node)
                   (progn
                     (set-filldawg-node-idx node index)
                     (incf index)
                     (incf index (length (filldawg-node-children node)))
                     (dolist (child (filldawg-node-children node))
                       (number-subtrie child)))
                   (set-filldawg-node-idx node 0))))
      (number-subtrie node))
    index))

(defun suffix-completes-a-word-p (suffix dawg-idx lexicon)
  (declare (optimize (safety 3) (debug 3)))
  (destructuring-bind (letter . new-suffix)
      suffix
    (let* ((dawg (lexicon-dawg lexicon))
           (nodes (dawg-nodes dawg))
           (letter2child-table (dawg-letter2child-table dawg)))
      (labels ((fast-child-idx (child-letter)
                 (aref letter2child-table
                       (i+ (i* 32 dawg-idx) child-letter))))
        (let ((child-idx (fast-child-idx (i1+ letter))))
          (when (iplusp child-idx)
            (let* ((child (aref nodes child-idx))
                   (new-dawg-idx (child-pointer child))
                   (whole-word-p (child-terminates child)))
              (if new-suffix
                  (and (iplusp new-dawg-idx)
                       (suffix-completes-a-word-p
                        new-suffix new-dawg-idx lexicon))
                  whole-word-p))))))))

;; Stupid and temporary anglocentric hack.
(defconstant +thru-delimiter+ 26)
(defconstant +segment-delimiter+ 27)

(defun filldawg-node-children-string (filldawg-idx lexicon tiles)
  (let* ((filldawg (lexicon-filldawg lexicon))
         (nodes (filldawg-nodes filldawg))
         (node (aref nodes filldawg-idx)))
    (apply #'concatenate
           (cons 'string
                 (append
                  (loop
                     for letter fixnum below 26
                     for tile = (aref tiles (i1+ letter))
                     when (logbitp letter node)
                     collect (tile-text tile))
                  (if (logbitp #.+thru-delimiter+ node) '("-") nil)
                  (if (logbitp #.+segment-delimiter+ node) '("/") nil))))))

(defun filldawg-prefix-node-idx (prefix-suffix filldawg-idx lexicon)
  (when (null prefix-suffix)
    (return-from filldawg-prefix-node-idx filldawg-idx))
  #+nil
  (format t "prefix-suffix: ~a filldawg-idx: ~a~%"
          (pattern2string prefix-suffix) filldawg-idx)
  (let* ((filldawg (lexicon-filldawg lexicon))
         (nodes (filldawg-nodes filldawg))
         (node (aref nodes filldawg-idx)))
    (labels ((node-has-child (datum)
               (logbitp datum node))
             (node-datum-offset (datum)
               (let ((mask (1- (iash 1 datum))))
                 (1+ (logcount (logand node mask)))))
             (find-child-idx (datum)
               (when (node-has-child datum)
                 (i+ filldawg-idx
                     (node-datum-offset datum)))))
      (destructuring-bind (datum . new-prefix-suffix)
          prefix-suffix
        #+nil
        (format t "datum: ~a filldawg-idx: ~a node: ~a~%"
                datum filldawg-idx node)
        (let ((child-idx (find-child-idx datum)))
          (when child-idx
            (let* ((child (aref nodes child-idx))
                   (new-filldawg-idx (child-pointer child)))
              (filldawg-prefix-node-idx new-prefix-suffix
                                        new-filldawg-idx
                                        lexicon))))))))

(defun filldawg-string-extensions (string lexicon)
  (let ((prefix (filldawg-string2list string)))
    (mapcar #'pattern2string
            (filldawg-extensions prefix
                                 (filldawg-prefix-node-idx prefix
                                                           0 *twl*)
                                 lexicon))))

(defun filldawg-extensions (prefix filldawg-idx lexicon)
  (declare (optimize debug))
  (when (null filldawg-idx)
    (return-from filldawg-extensions nil))
  #+nil
  (format t "prefix: ~a  filldawg-idx:~a~%"
          (pattern2string prefix) filldawg-idx)
  (let* ((filldawg (lexicon-filldawg lexicon))
         (nodes (filldawg-nodes filldawg))
         (node (aref nodes filldawg-idx)))
    (labels ((node-has-child (datum)
               (logbitp datum node))
             (num-children ()
               (logcount node))
             (nth-child-datum (n)
               (loop
                  with found = 0
                  for datum below 28
                  when (node-has-child datum)
                  do (if (i= found n)
                         (return-from nth-child-datum datum)
                         (iincf found)))))
      (apply #'append
              (loop
                 for n below (num-children)
                 for datum = (nth-child-datum n)
                 for child-idx = (+ 1 n filldawg-idx)
                 for child-node = (aref nodes child-idx)
                 for new-filldawg-idx = (logand child-node
                                                (1- (ash 1 28)))
                 for new-prefix = (append prefix (list datum))
                 when (filldawg-node-whole-word-p child-node)
                 collect (list new-prefix)
                 when (iplusp new-filldawg-idx)
                 collect (filldawg-extensions new-prefix
                                              new-filldawg-idx
                                              lexicon))))))

(defun list-is-word-p (word &optional (lexicon *twl*))
  (suffix-completes-a-word-p word 0 lexicon))

(defun filldawg-patterns (word max-new-tiles max-thrus allow-phony-thrus-p)
  ;(declare (optimize (speed 3) (safety 0) (space 1) (debug 0)))
  (let ((possible-splits nil))
    (labels ((push-partitions (prefix-groups suffix)
               (push (append prefix-groups (list suffix)) possible-splits)
               (loop 
                  for first-length from 1 to (i1- (length suffix))
                  for first = (subseq (the list suffix) 0 first-length)
                  for rest = (subseq (the list suffix) first-length)
                  do (push-partitions (append prefix-groups (list first)) rest)))
             (all-valid (thru-strings)
               (when (i> (length thru-strings) max-thrus)
                 (return-from all-valid nil))
               (let* ((num-thru-tiles (apply '+ (mapcar #'length thru-strings)))
                      (num-gap-tiles (i- (length word) num-thru-tiles)))
                 (when (or (i> num-gap-tiles max-new-tiles)
                           (izerop num-gap-tiles))
                   (return-from all-valid nil))
                 (when allow-phony-thrus-p
                   (return-from all-valid t))
                 (loop 
                    for string in thru-strings
                    always (or (null (cdr string))
                               (list-is-word-p string)))))
             (collect-thru/gap-starting (split thru-p)
               (loop
                  for thru in split
                  for idx fixnum from 0
                  when (i= (ilogand idx 1) (if thru-p 0 1))
                  collect thru))
             (codify-split (thrus gaps)
               (append (apply #'append
                              (loop
                                 for idx from 0
                                 for thru in thrus
                                 collect (append thru
                                                 (if (i< idx (i1- (length thrus)))
                                                     (list #.+thru-delimiter+)
                                                     nil))))
                       (list #.+segment-delimiter+)
                       (loop
                          for gap in (if (i< (length thrus) (length gaps))
                                         (butlast gaps)
                                         gaps)
                          collect (length gap))
                       (list #.+segment-delimiter+)
                       (apply #'append gaps))))
      (push-partitions nil word)
      (loop
         for split in possible-splits
         for thru-starting-thrus = (collect-thru/gap-starting split t)
         for gap-starting-thrus = (collect-thru/gap-starting split nil)
         when (all-valid thru-starting-thrus)
         collect (codify-split thru-starting-thrus
                               (cons nil gap-starting-thrus))
         when (all-valid gap-starting-thrus)
         collect (codify-split gap-starting-thrus thru-starting-thrus)))))

(defun pattern2string (pattern)
  (coerce (loop
             with segment = 0
             for datum in pattern collect
               (cond ((= datum +thru-delimiter+)
                      #\-)
                     ((= datum +segment-delimiter+)
                      (progn (incf segment) #\/))
                     ((= segment 1) ;; gap lengths
                      (code-char (+ (char-code #\0) datum)))
                     (t             ;; thrus or gaps
                      (letter2char datum))))
          'string))

(defun filldawg-string2list (string)
  (loop 
     for letter across string
     collect (cond ((and (>= (char-code letter) (char-code #\A))
                         (<= (char-code letter) (char-code #\Z))) 
                    (- (char-code letter) (char-code #\A)))
                   ((and (>= (char-code letter) (char-code #\a))
                         (<= (char-code letter) (char-code #\z))) 
                    (- (char-code letter) (char-code #\a)))
                   ((eq letter #\-) +thru-delimiter+)
                   ((eq letter #\/) +segment-delimiter+)
                   (t (- (char-code letter) (char-code #\0))))))

(defun filldawg-trie-from-file (&optional filename (max-newly-placed 7)
                                          (max-thrus MOST-POSITIVE-FIXNUM))
  (setf filename (string-append *data-directory* (or filename "twl.txt")))
  (let ((trie (make-filldawg-node)))
    (do-file-lines (word filename)
      (let* ((word-list (word2list word))
             (patterns (filldawg-patterns word-list
                                          max-newly-placed
                                          max-thrus
                                          nil)))
        (dolist (pattern patterns)
          (filldawg-push-word pattern trie))))
    trie))

(defun count-filldawg-patterns (&optional filename (max-newly-placed 7)
                                          (max-thrus MOST-POSITIVE-FIXNUM))
                                
  (setf filename (string-append *data-directory* (or filename "twl.txt")))
  (let ((num-patterns 0))
    (do-file-lines (word filename)
      (let* ((word-list (word2list word))
             (patterns (filldawg-patterns word-list
                                          max-newly-placed
                                          max-thrus
                                          t)))
        (incf num-patterns (length patterns))))
    num-patterns))

(defun filldawg-from-wordlist (wordlist filldawg
                               &optional (max-newly-placed 7)
                               (max-thrus MOST-POSITIVE-FIXNUM))
   (let* ((trie (filldawg-trie-from-file wordlist
                                         max-newly-placed
                                         max-thrus))
          (filldawg (string-append *data-directory* filldawg))
          (size (progn
                  (filldawg-sort-children trie)
                  (filldawg-number-trie trie))))
    (with-open-file (stream
                     filldawg
                     :direction :output
                     :element-type '(unsigned-byte 32)
                     :if-does-not-exist :create)
      (labels ((write-node (node)
                 (when (filldawg-node-children node)
                   (write-byte (filldawg-node-child-bits node) stream)
                   (dolist (child (filldawg-node-children node))
                     (write-byte (filldawg-node-bits child) stream))
                   (dolist (child (filldawg-node-children node))
                     (write-node child)))))
        (write-byte size stream)
        (write-node trie)))))

;; http://en.wikipedia.org/wiki/Scrabble_variants
(defstruct rules
  clabbers-p ; implemented in the dawg
  woadwage-p ; lexicon = words + concatenations of two words
  escalating-p ; bingo player's rack grows by one
  recycle-p ; swap on-board blank with on-rack blank representation
  if-only-p ; may turn one natural tile into a blank
  toroidal-p 
  bingo-bonus  
  max-scoreless-turns
  challenge-rule ; (:single :double :penalty-per-word :penalty-per-move)
  challenge-penalty
  overdraw-rule ; (:naspa :wespa)
  time-limit
  time-penalty-duration
  time-penalty)

(defun list2text (list &optional (tiles *english*))
  (apply #'concatenate
          (cons 'string
                (mapcar (lambda (letter)
                          (tile-text (aref tiles letter)))
                        list))))

(defun fit-between (before after lexicon)
  (declare (optimize (debug 3)))
  (unless (or before after)
    (return-from fit-between +all-letters+))
  (let* ((pattern
          (cond ((null before) (append after '(#.+segment-delimiter+ 1
                                               #.+segment-delimiter+)))
                ((null after) (append before '(#.+segment-delimiter+ 0
                                               #.+segment-delimiter+)))
                (t (append before '(#.+thru-delimiter+) after
                           '(#.+segment-delimiter+ 0 1
                             #.+segment-delimiter+)))))
         (filldawg (lexicon-filldawg lexicon))
         (nodes (filldawg-nodes filldawg))
         (node-idx (filldawg-prefix-node-idx pattern 0 lexicon))
         (node (and node-idx (aref nodes node-idx))))
    (when (null node)
      (return-from fit-between 0))
    (labels ((node-has-child (letter)
               (logbitp letter node))
             (num-children ()
               (logcount node))
             (nth-child-letter (n)
               (loop
                  with found = 0
                  for letter below 26
                  when (node-has-child letter)
                  do (if (i= found n)
                         (return-from nth-child-letter letter)
                         (iincf found)))))
      (let ((bits 0))
        (loop
           for n below (num-children)
           for letter = (nth-child-letter n)
           for child-idx = (+ 1 n node-idx)
           for child-node = (aref nodes child-idx)
           when (filldawg-node-whole-word-p child-node) do
             (setf (logbitp letter bits) t))
        bits))))

(defun zero-aligned-bit-letters (bits tiles)
  (apply #'concatenate
         (cons 'string
               (loop
                  for letter fixnum below 26
                  for tile = (aref tiles (1+ letter))
                  when (logbitp letter bits)
                  collect (tile-text tile)))))

(defun string-fit-between (before after
                           &optional (lexicon *twl*) (tiles *english*))
  (zero-aligned-bit-letters (fit-between (word2list before)
                                         (word2list after)
                                         lexicon)
                            tiles))
                       
(defun update-sq-infos (board lexicon tiles
                        &optional (debug-p t) (rack-size 7) last-move)
 (declare (optimize (debug 3)))
 (declare (ignore last-move))
 (let* ((layout (board-layout board))
        (height (layout-height layout))
        (width (layout-width layout))
        (letters (board-letters board))
        (blank-ps (board-blank-ps board))
        (sq-infos (board-sq-infos board))
        (nodes (board-nodes board))
        (blank (tiles-blank tiles)))
  (macrolet ((do-squares ((row col dir sq-info h/v) &body body)
               `(dotimes (,row height)
                  (dotimes (,col width)
                    (dolist (,dir '(:horizontal :vertical))
                      (let* ((,sq-info (aref sq-infos row col))
                             (,h/v (if (eq ,dir :horizontal)
                                       (sq-info-v ,sq-info)
                                       (sq-info-h ,sq-info))))
                        ,@body))))))
   (labels ((on-board-p (r c)
               (and (<= 0 r (1- height))
                    (<= 0 c (1- width))))
             (next-sq (r c l-to-r-p dir)
               (if (eq dir :horizontal)
                   (if l-to-r-p
                       (values r (i1+ c))
                       (values r (i1- c)))
                   (if l-to-r-p
                       (values (i1+ r) c)
                       (values (i1- r) c))))
             (get-word (r c l-to-r-p dir)
               (multiple-value-bind (next-r next-c)
                   (next-sq r c l-to-r-p dir)
                 (when (on-board-p next-r next-c)
                   (let ((letter (aref letters next-r next-c)))
                     (unless (i= letter +empty+)
                       (append (list (1- (aref letters next-r next-c)))
                               (get-word next-r next-c l-to-r-p dir)))))))
             (get-score (r c l-to-r-p dir)
               (multiple-value-bind (next-r next-c)
                   (next-sq r c l-to-r-p dir)
                 (if (on-board-p next-r next-c)
                     (let ((letter (aref letters next-r next-c)))
                       (if (i= letter +empty+)
                           0
                           (let* ((blank-p (aref blank-ps next-r next-c))
                                  (tile-idx (if blank-p blank letter))
                                  (tile (aref tiles tile-idx))
                                  (score (tile-score tile)))
                             (i+ score
                                 (get-score next-r next-c l-to-r-p dir)))))
                     0)))
             (thru-words (row col dir)
               #+nil
               (format t  "(thru-words ~a ~a) dir: ~a~%"
                       row col dir)
               (multiple-value-bind (prev-r prev-c)
                   (next-sq row col nil dir)
                 (when (and (on-board-p prev-r prev-c)
                            (iplusp (aref letters prev-r prev-c)))
                   (return-from thru-words nil)))
               (let ((words nil)
                     (gaps (list 0))
                     (last-tile :gap)
                     (num-tiles 0)
                     (r row)
                     (c col))
                 (loop
                    (unless (on-board-p r c)
                      (return-from thru-words
                        (values (reverse (mapcar #'reverse words))
                                (if (eq last-tile :gap)
                                    (reverse (rest gaps))
                                    (reverse gaps)))))
                    (let ((letter (aref letters r c)))
                      #+nil
                      (format t "r: ~a c: ~a letter: ~a words: ~a gaps: ~a ~
                                  last: ~a num-tiles: ~a~%"
                              r c letter words gaps last-tile num-tiles)
                      (if (izerop letter)
                          (progn
                            (if (eq last-tile :gap)
                                (iincf (first gaps))
                                (progn
                                  (push 1 gaps)
                                  (setf last-tile :gap)))
                            (incf num-tiles)
                            (when (i> num-tiles rack-size)
                              (return-from thru-words
                                (values (reverse (mapcar #'reverse words))
                                        (reverse (rest gaps))))))
                          (if (eq last-tile :gap)
                              (progn
                                (push (list letter) words)
                                (setf last-tile :letter))
                              (push letter (first words))))
                      (multiple-value-setq (r c)
                        (next-sq r c t dir))))))
             (pattern (thrus gaps)
               (when (null thrus) (return-from pattern nil))
               (apply #'append
                      (loop
                         for (thru . more) on thrus
                         collect (mapcar #'1- thru)
                         when more
                         collect (list +thru-delimiter+)
                         unless more
                         collect (append (list +segment-delimiter+)
                                         gaps
                                         (list +segment-delimiter+)))))
             (cross-at (r c dir)
               (let* ((sq-info (aref sq-infos r c))
                      (h/v (if (eq dir :horizontal)
                               (sq-info-h sq-info)
                               (sq-info-v sq-info))))
                 (h/v-cross h/v)))
             (score-at (r c)
               (let ((letter (aref letters r c)))
                 (if (i= letter +empty+)
                     0
                     (let* ((blank-p (aref blank-ps r c))
                            (tile-idx (if blank-p blank letter))
                            (tile (aref tiles tile-idx)))
                       (tile-score tile)))))
             (patterns (thrus gaps row col dir)
               (let ((patterns (make-array `(,rack-size)))
                     (scores (make-array `(,rack-size)))
                     (positions (make-array `(,rack-size))))
                 (loop
                    ;; Really need to clean this up
                    with min-tiles = 0
                    with score = 0
                    with r = row
                    with c = col
                    for num-used from 0 to (length thrus)
                    for used-thrus = (subseq thrus 0 num-used)
                    for used-gaps = (subseq gaps 0 num-used)
                    for next-thru-size = (if thrus
                                             (length (first (last used-thrus)))
                                             0)
                    for next-gap = (if (i= num-used (length thrus))
                                       rack-size
                                       (nth num-used gaps))
                    for max-tiles = (if (i< num-used (length thrus))
                                        (if used-thrus
                                            (if (and (izerop (first gaps))
                                                     (i= num-used 1))
                                                (i+ min-tiles next-gap -2)
                                                (i+ min-tiles next-gap -1))
                                            (i+ min-tiles next-gap -2))
                                        (i1- rack-size))
                    for ahead-r = r
                    for ahead-c = c
                    do
                      (loop
                         named :find-nonempty-square do
                           (when (or (not (on-board-p ahead-r ahead-c))
                                     (iplusp (aref letters ahead-r ahead-c)))
                             (return-from :find-nonempty-square))
                           (multiple-value-setq (ahead-r ahead-c)
                             (next-sq ahead-r ahead-c t dir)))
                      (loop
                         repeat next-thru-size do
                           (when debug-p
                             (format t "ahead-r: ~a ahead-c: ~a~%" ahead-r ahead-c))
                           (when (on-board-p ahead-r ahead-c)
                             (when debug-p
                               (format t "(score-at ahead-r ahead-c): ~a~%"
                                       (score-at ahead-r ahead-c)))
                             (iincf score (score-at ahead-r ahead-c)))
                           (multiple-value-setq (ahead-r ahead-c)
                             (next-sq ahead-r ahead-c t dir)))
                      (when debug-p
                        (format t "min-tiles: ~a num-used: ~a max-tiles: ~a ~
                                   used-thrus: ~a~%~
                                   used-gaps: ~a next-gap: ~a next-thru-size: ~a~%"
                                min-tiles num-used max-tiles used-thrus used-gaps
                                next-gap next-thru-size))
                      (when (i<= 0 max-tiles)
                        (loop
                           with hooked-p = nil
                           for num-tiles from min-tiles to max-tiles do
                             (when (or (iplusp num-tiles)
                                       (and (first gaps)
                                            (izerop (first gaps))
                                            (izerop num-tiles)))
                               (loop
                                  named :advance-to-next-empty-square do
                                    (multiple-value-setq (r c)
                                      (next-sq r c t dir))
                                    (when (or (not (on-board-p r c))
                                              (i= +empty+ (aref letters r c)))
                                      (return-from :advance-to-next-empty-square))))
                             (when debug-p
                               (format t "r: ~a c: ~a~%" r c))
                             (if (on-board-p r c)
                                 (let ((cross (cross-at r c dir)))
                                   (setf hooked-p (or hooked-p (iplusp cross))
                                         (aref scores num-tiles) score
                                         (aref positions num-tiles)
                                         (if (eq dir :horizontal)
                                             (i- c col)
                                             (i- r row))
                                         (aref patterns num-tiles)
                                         (if used-thrus
                                             (pattern used-thrus used-gaps)
                                             (if hooked-p
                                                 '(#.+segment-delimiter+
                                                   #.+segment-delimiter+)
                                                 nil)))
                                   (when debug-p
                                     (format t "  r: ~a c: ~a dir: ~a cross: ~a ~
                                              score: ~a hooked-p: ~a used-thrus: ~a ~
                                              used-gaps: ~a~%"
                                             r c dir cross score hooked-p
                                             used-thrus used-gaps)))
                                 (setf (aref patterns num-tiles) nil)))
                        (setf min-tiles (i1+ max-tiles))))
                 (values patterns scores positions))))

   (do-squares (row col dir sq-info h/v)
      (let ((letter (aref letters row col)))
        (when (i= +empty+ letter)
          (let* ((before (reverse (get-word row col nil dir)))
                 (after (get-word row col t dir))
                 (between (fit-between before after lexicon))
                 (before-score (get-score row col nil dir))
                 (after-score (get-score row col t dir)))
            (setf (h/v-cross h/v) between
                  (h/v-score h/v) (i+ before-score after-score))))
        #+nil
        (when (i/= +empty+ letter)
          (format t "row: ~a col: ~a dir: ~a~%" row col dir))))

   (do-squares (row col dir sq-info h/v)
     (multiple-value-bind (prev-r prev-c)
         (next-sq row col nil dir)
       (unless (and (on-board-p prev-r prev-c)
                    (iplusp (aref letters prev-r prev-c)))
         (multiple-value-bind (thrus gaps)
             (thru-words row col dir)
           (when debug-p
             (format t "row: ~a col: ~a dir :~a thrus: ~a gaps: ~a~%"
                     row col dir (mapcar #'list2text thrus) gaps))
           (multiple-value-bind (thru-patterns scores positions)
               (patterns thrus gaps row col dir)
             (when debug-p
               (format t "scores: ~a~%" scores))
             (setf (h/v-nodes h/v) (map 'vector
                                        (lambda (pattern)
                                          (or (filldawg-prefix-node-idx
                                               pattern 0 lexicon)
                                              0))
                                        thru-patterns)
                   (h/v-scores h/v) scores
                   (h/v-positions h/v) positions)
             #+nil
             (loop
                for pattern across thru-patterns
                for num-tiles fixnum from 1
                for node = (filldawg-prefix-node-idx pattern 0 lexicon)
                for example-lists = (and pattern debug-p
                                         (not (equal node 35168598))
                                         (filldawg-extensions
                                          nil node lexicon))
                for of-correct-length = (loop
                                           for list in example-lists
                                           when (i= (length list) num-tiles)
                                           collect list)
                for example-words =
                  (mapcar #'pattern2string
                          (subseq
                           of-correct-length 0
                           (min 10 (length of-correct-length))))
                do
                  (when debug-p
                    (format t "pattern: ~a num: ~a examples: ~a~%"
                            (pattern2string pattern)
                            num-tiles
                            example-words))))))))))))

(defstruct perm-elt
  change-pos
  pos-value
  next)

(defstruct perm-seq
  num-items
  elts)

(defvar *base-perm-seq-cache* (make-hash-table))
(defvar *unique-perm-seq-cache* (make-hash-table :test 'equal))

(defun new-perm-seq (n &optional (memoize-p t))
  (when memoize-p
    (return-from new-perm-seq
      (or (gethash n *base-perm-seq-cache*)
          (setf (gethash n *base-perm-seq-cache*)
                (new-perm-seq n nil)))))

  (let ((elts nil)
        (old-indices (make-array (list n)
				 :element-type 'fixnum
				 :initial-element -1))
	(indices (make-array (list n))))
    (dotimes (index n) (setf (aref indices index) index))
    (labels ((reverse-from (start)
	       (loop
		  for reverse1 from start below n
		  for reverse2 from (i1- n) downto start
		  while (i< reverse1 reverse2)
		  do (rotatef (aref indices reverse1)
			      (aref indices reverse2))))

	     ;; ported from C++ STL <algorithm>
	     (set-next-perm ()
	       (when (i> 2 n)
		 (return-from set-next-perm nil))
	       (loop
		  with i = (i1- n)
		  for j = i
		  do 
		    (idecf i)
		    (when (i< (aref indices i) (aref indices j))
		      (let ((k (i1- n)))
			(loop
			   while (i>= (aref indices i)
				      (aref indices k))
			   do (idecf k))
			(rotatef (aref indices i) (aref indices k))
			(reverse-from j)
			(return-from set-next-perm t)))
		    (when (izerop i)
		      (reverse-from 0)
		      (return-from set-next-perm nil)))))

      (loop :named changes do
	 (loop
	    with change-p = nil
	    for i below n do
	      (when (or change-p (i/= (aref indices i)
				      (aref old-indices i)))
		(let ((e (make-perm-elt
			  :change-pos i
			  :pos-value (aref indices i))))
		  (push e elts)
		  (setf change-p t))))
	 (dotimes (i n) (setf (aref old-indices i) (aref indices i)))
	 (unless (set-next-perm)
	   (return-from changes)))

      (dotimes (i n) (setf (aref indices i) (length elts)))

      (setf elts (make-array (list (length elts))
                             :initial-contents (nreverse elts)))

      (loop 
         with size = (length elts)
         for r from (i1- size) downto 0
         for elt = (aref elts r)
         do
           (setf (perm-elt-next elt)
                 (aref indices (perm-elt-change-pos elt)))
           (loop
              for q from (perm-elt-change-pos elt) below n do
                (setf (aref indices q) r)))
      
      (make-perm-seq :num-items n :elts elts))))

(defun get-perm-constraints (rack)
  (let* ((size (rack-size rack))
         (constraints (make-array size))
         (constraint-p nil)
         (same-indices 1))
    (dotimes (i size) (setf (aref constraints i) (cons 0 0)))
    (loop
       for i from 1 below size do
         (when (i/= (aref (rack-tiles rack) i)
                    (aref (rack-tiles rack) (i1- i)))
           (setf same-indices 0))
         (setf (car (aref constraints i)) same-indices)
         (when (iplusp same-indices)
           (setf constraint-p t))
         (set-bitf same-indices i))
    (values constraint-p constraints)))

(defun constraint-key (rack)
  (multiple-value-bind (constraint-p constraints)
      (get-perm-constraints rack)
    (declare (ignore constraint-p))
    (loop for (a . b) across constraints collecting a)))

(defun test-perm-constraints (constraints pos index)
  (let ((preceding-indices (if (izerop pos)
                               0
                               (cdr (aref constraints (i1- pos)))))
        (required-preceding-indices (car (aref constraints index))))
    (when (i/= (ilogand required-preceding-indices preceding-indices)
               required-preceding-indices)
      (return-from test-perm-constraints nil))
    (setf (cdr (aref constraints pos))
          (ilogior preceding-indices (1bit index)))))

(defun unique-rack-perms (rack &optional (memoize-p t))
  (when memoize-p
    (let ((key (constraint-key rack)))
      (return-from unique-rack-perms
        (or (gethash key *unique-perm-seq-cache*)
            (setf (gethash key *unique-perm-seq-cache*)
                  (unique-rack-perms rack nil))))))

  (let* ((base (new-perm-seq (rack-size rack) memoize-p)))
    (multiple-value-bind (constraint-p constraints)
        (get-perm-constraints rack)

      (when (null constraint-p)
        (return-from unique-rack-perms base))

      (let* ((seq (make-perm-seq :elts (copy-seq
                                        (perm-seq-elts base))))
             (orig-size (length (perm-seq-elts seq)))
             (orig2filtered (make-array (list (i1+ orig-size))))
             (j 0))

        (loop :named test-constraints
           with i = 0
           for elt = (aref (perm-seq-elts seq) i) do
             (if (test-perm-constraints constraints
                                        (perm-elt-change-pos elt)
                                        (perm-elt-pos-value elt))
                 (progn
                   (setf (aref orig2filtered i) j
                         (aref (perm-seq-elts seq) j) elt)
                   (iincf j)
                   (iincf i)
                   (when (i= i (length (perm-seq-elts seq)))
                     (return-from test-constraints)))
                 (progn
                   (setf (aref orig2filtered i) MOST-POSITIVE-FIXNUM)
                   (setf i (perm-elt-next elt))
                   (when (i= i (length (perm-seq-elts seq)))
                     (return-from test-constraints)))))

        (setf (perm-seq-elts seq)
              (adjust-array (perm-seq-elts seq) (list j)))

        (setf (aref orig2filtered orig-size) j)
        
        (loop
           for i from (i1- orig-size) downto 0
           for f = (aref orig2filtered i) do
             (when (i= MOST-POSITIVE-FIXNUM f)
               (let* ((elt (aref (perm-seq-elts base) i))
                      (next (perm-elt-next elt)))
                 (setf f (aref orig2filtered next))
                 (setf (aref orig2filtered i) f)
                 (assert (i>= next i))
                 (assert (i<= f j)))))

        (loop
           for i below j
           for elt = (aref (perm-seq-elts seq) i) do
             (assert (i<= (perm-elt-next elt) orig-size))
             (setf (perm-elt-next elt)
                   (aref orig2filtered (perm-elt-next elt)))
             (assert (<= (perm-elt-next elt) j))
             #+nil
             (format t "(perm-elt-next elt): ~a j: ~a perm-elt-change-pos-blah: ~a~%"
                     (perm-elt-next elt) j
                     (when (i/= (perm-elt-next elt) j)
                       (perm-elt-change-pos
                        (aref (perm-seq-elts seq)
                              (perm-elt-next elt)))))
             (assert (or (i= (perm-elt-next elt) j)
                         (>= (perm-elt-change-pos elt)
                             (perm-elt-change-pos
                              (aref (perm-seq-elts seq)
                                    (perm-elt-next elt)))))))
        
        seq))))