chiark - git - mdw - wordchain/blob - chain.lisp

   1 ;;; -*-lisp-*-
   2
   3 (defstruct (node (:predicate nodep)
   4                  (:constructor make-node (word)))
   5   (word (error "uninitialized slot") :type string :read-only t)
   6   (len 0 :type fixnum)
   7   (up nil :type (or node null))
   8   (down nil :type (or node null))
   9   (right nil :type (or node null)))
  10
  11 (defun word-chain (stream)
  12   (declare (optimize speed))
  13
  14   (let ((map (make-hash-table :test #'equal))
  15         (max 0) (winners nil))
  16
  17     (loop
  18       (let ((line (read-line stream nil)))
  19         (unless line (return))
  20         (setf (gethash line map) (make-node line))))
  21
  22     (maphash (lambda (word node)
  23                (declare (type string word)
  24                         (type node node))
  25
  26                ;;(format t ";; contemplate `~A'~%" word)
  27                (let ((parent (let ((len (length word)))
  28                                (and (>= len 1)
  29                                     (gethash (subseq word 0 (1- len))
  30                                              map))))
  31                      (nlen (node-len node)))
  32                  (when parent
  33                    (setf (node-up node) parent)
  34                    (loop
  35                      (unless parent
  36                        (when (>= nlen max)
  37                          (when (> nlen max)
  38                            (setf max nlen
  39                                  winners nil))
  40                          (push node winners))
  41                        (return))
  42                      (incf nlen)
  43                      (let ((plen (node-len parent)))
  44                        ;;(format t ";; node `~A' ~D parent `~A' ~D~%"
  45                        ;;              (node-word node) (1- nlen)
  46                        ;;              (node-word parent) plen)
  47                        (cond ((> plen nlen)
  48                               ;;(format t ";; longer chain through `~A'~%"
  49                               ;;              (node-word (node-down parent)))
  50                               (return))
  51                              ((= plen nlen)
  52                               (setf (node-right node) (node-down parent)
  53                                     (node-down parent) node)
  54                               (return))
  55                              (t
  56                               ;;(format t ";; new longest chain ~A > ~A~%"
  57                               ;;              nlen plen)
  58                               (setf (node-down parent) node
  59                                     (node-right node) nil
  60                                     (node-len parent) nlen
  61                                     node parent
  62                                     parent (node-up node)))))))))
  63              map)
  64
  65     (labels ((print-chain (node)
  66                (cond ((null (node-right node))
  67                       (write-string (node-word node))
  68                       (let ((down (node-down node)))
  69                         (when down
  70                           (write-char #\space)
  71                           (print-chain down))))
  72                      (t
  73                       (write-string "{ ")
  74                       (loop
  75                         (write-string (node-word node))
  76                         (let ((down (node-down node)))
  77                           (when down
  78                             (write-char #\space)
  79                             (print-chain down)))
  80                         (let ((right (node-right node)))
  81                           (unless right (return))
  82                           (write-string " | ")
  83                           (setf node right)))
  84                       (write-string " }")))))
  85       (dolist (node winners)
  86         (print-chain node)
  87         (terpri)))))
  88
  89 #+runlisp-script
  90 (let ((args (uiop:command-line-arguments))
  91       (timing-out nil))
  92
  93   (handler-bind ((warning #'muffle-warning))
  94     (let ((*compile-verbose* nil))
  95       (compile 'word-chain)))
  96
  97   (when (and args (>= (length (car args)) 2)
  98              (string= (car args) "-T" :end1 2))
  99     (let ((arg (pop args)))
 100       (setf timing-out (if (= (length arg) 2) t
 101                            (subseq arg 2)))))
 102
 103   (let (t0 t1 t2)
 104     (setf t0 (get-internal-run-time)) ; warm cache
 105     (setf t0 (get-internal-run-time)) ; start time
 106     (setf t1 (get-internal-run-time)) ; overhead
 107     (flet ((hack-file (path)
 108              (cond ((string= path "-") (word-chain *standard-input*))
 109                    (t (with-open-file (stream path) (word-chain stream))))))
 110       (cond ((null args)
 111              (word-chain *standard-input*))
 112             ((null (cdr args))
 113              (hack-file (car args)))
 114             (t
 115              (dolist (arg args)
 116                (format t "~A: " arg)
 117                (hack-file arg)))))
 118     (setf t2 (get-internal-run-time)) ; final time
 119
 120     (flet ((write-time (stream)
 121              (format stream "~,3F~%"
 122                      (/ (max 0 (+ t2 t0 (* -2 t1)))
 123                         internal-time-units-per-second))))
 124       (cond ((eq timing-out t)
 125              (write-string ";; time = ")
 126              (write-time *standard-output*))
 127             (timing-out
 128              (with-open-file (stream timing-out
 129                               :direction :output
 130                               :if-does-not-exist :create
 131                               :if-exists :supersede)
 132                (write-time stream)))))))