more stuff found lying about

[wordchain] / chain.lisp

diff --git a/chain.lisp b/chain.lisp
index 214091c9f8b0c0c2aa208eb091a76913fde42779..1f0abaa24cf5f7f1e9ba9492ccee0c11ae3bebbb 100755 (executable)
--- a/chain.lisp
+++ b/chain.lisp
@@ -12,7 +12,7 @@ (defun word-chain (stream)
   (declare (optimize speed))
 
   (let ((map (make-hash-table :test #'equal))
   (declare (optimize speed))
 
   (let ((map (make-hash-table :test #'equal))

-       (max 0))
+       (max 0) (winners nil))

 
     (loop
       (let ((line (read-line stream nil)))
 
     (loop
       (let ((line (read-line stream nil)))


@@ -29,61 +29,62 @@ (defun word-chain (stream)
                                    (gethash (subseq word 0 (1- len))
                                             map))))
                     (nlen (node-len node)))
                                    (gethash (subseq word 0 (1- len))
                                             map))))
                     (nlen (node-len node)))

-                (setf (node-up node) parent)
-                (loop
-                  (unless parent (return))
-                  (incf nlen)
-                  (let ((plen (node-len parent)))
-                    ;;(format t ";; node `~A' ~D parent `~A' ~D~%"
-                    ;;        (node-word node) (1- nlen)
-                    ;;        (node-word parent) plen)
-                    (cond ((> plen nlen)
-                           ;;(format t ";; longer chain through `~A'~%"
-                           ;;        (node-word (node-down parent)))
-                           (return))
-                          ((= plen nlen)
-                           (setf (node-right node) (node-down parent)
-                                 (node-down parent) node)
-                           (return))
-                          (t
-                           ;;(format t ";; new longest chain ~A > ~A~%"
-                           ;;        nlen plen)
-                           (setf (node-down parent) node
-                                 (node-right node) nil
-                                 (node-len parent) nlen
-                                 node parent
-                                 parent (node-up node))))))
-                (when (> nlen max) (setf max nlen))))
+                (when parent
+                  (setf (node-up node) parent)
+                  (loop
+                    (unless parent
+                      (when (>= nlen max)
+                        (when (> nlen max)
+                          (setf max nlen
+                                winners nil))
+                        (push node winners))
+                      (return))
+                    (incf nlen)
+                    (let ((plen (node-len parent)))
+                      ;;(format t ";; node `~A' ~D parent `~A' ~D~%"
+                      ;;              (node-word node) (1- nlen)
+                      ;;              (node-word parent) plen)
+                      (cond ((> plen nlen)
+                             ;;(format t ";; longer chain through `~A'~%"
+                             ;;              (node-word (node-down parent)))
+                             (return))
+                            ((= plen nlen)
+                             (setf (node-right node) (node-down parent)
+                                   (node-down parent) node)
+                             (return))
+                            (t
+                             ;;(format t ";; new longest chain ~A > ~A~%"
+                             ;;              nlen plen)
+                             (setf (node-down parent) node
+                                   (node-right node) nil
+                                   (node-len parent) nlen
+                                   node parent
+                                   parent (node-up node)))))))))

             map)
 
             map)
 

-    (maphash (lambda (word node)
-              (declare (ignore word)
-                       (type node node))
-
-              (when (= (node-len node) max)
-                (labels ((print-chain (node)
-                           (cond ((null (node-right node))
-                                  (write-string (node-word node))
-                                  (let ((down (node-down node)))
-                                    (when down
-                                      (write-char #\space)
-                                      (print-chain down))))
-                                 (t
-                                  (write-string "{ ")
-                                  (loop
-                                    (write-string (node-word node))
-                                    (let ((down (node-down node)))
-                                      (when down
-                                        (write-char #\space)
-                                        (print-chain down)))
-                                    (let ((right (node-right node)))
-                                      (unless right (return))
-                                      (write-string " | ")
-                                      (setf node right)))
-                                  (write-string " }")))))
-                  (print-chain node)
-                  (terpri))))
-            map)))
+    (labels ((print-chain (node)
+              (cond ((null (node-right node))
+                     (write-string (node-word node))
+                     (let ((down (node-down node)))
+                       (when down
+                         (write-char #\space)
+                         (print-chain down))))
+                    (t
+                     (write-string "{ ")
+                     (loop
+                       (write-string (node-word node))
+                       (let ((down (node-down node)))
+                         (when down
+                           (write-char #\space)
+                           (print-chain down)))
+                       (let ((right (node-right node)))
+                         (unless right (return))
+                         (write-string " | ")
+                         (setf node right)))
+                     (write-string " }")))))
+      (dolist (node winners)
+       (print-chain node)
+       (terpri)))))

 
 #+runlisp-script
 (let ((args (uiop:command-line-arguments))
 
 #+runlisp-script
 (let ((args (uiop:command-line-arguments))