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))
  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                  (setf (node-up node) parent)
  33                  (loop
  34                    (unless parent (return))
  35                    (incf nlen)
  36                    (let ((plen (node-len parent)))
  37                      ;;(format t ";; node `~A' ~D parent `~A' ~D~%"
  38                      ;;        (node-word node) (1- nlen)
  39                      ;;        (node-word parent) plen)
  40                      (cond ((> plen nlen)
  41                             ;;(format t ";; longer chain through `~A'~%"
  42                             ;;        (node-word (node-down parent)))
  43                             (return))
  44                            ((= plen nlen)
  45                             (setf (node-right node) (node-down parent)
  46                                   (node-down parent) node)
  47                             (return))
  48                            (t
  49                             ;;(format t ";; new longest chain ~A > ~A~%"
  50                             ;;        nlen plen)
  51                             (setf (node-down parent) node
  52                                   (node-right node) nil
  53                                   (node-len parent) nlen
  54                                   node parent
  55                                   parent (node-up node))))))
  56                  (when (> nlen max) (setf max nlen))))
  57              map)
  58
  59     (maphash (lambda (word node)
  60                (declare (ignore word)
  61                         (type node node))
  62
  63                (when (= (node-len node) max)
  64                  (labels ((print-chain (node)
  65                             (cond ((null (node-right node))
  66                                    (write-string (node-word node))
  67                                    (let ((down (node-down node)))
  68                                      (when down
  69                                        (write-char #\space)
  70                                        (print-chain down))))
  71                                   (t
  72                                    (write-string "{ ")
  73                                    (loop
  74                                      (write-string (node-word node))
  75                                      (let ((down (node-down node)))
  76                                        (when down
  77                                          (write-char #\space)
  78                                          (print-chain down)))
  79                                      (let ((right (node-right node)))
  80                                        (unless right (return))
  81                                        (write-string " | ")
  82                                        (setf node right)))
  83                                    (write-string " }")))))
  84                    (print-chain node)
  85                    (terpri))))
  86              map)))
  87
  88 #+runlisp-script
  89 (let ((args (uiop:command-line-arguments))
  90       (timing-out nil))
  91
  92   (handler-bind ((warning #'muffle-warning))
  93     (let ((*compile-verbose* nil))
  94       (compile 'word-chain)))
  95
  96   (when (and args (>= (length (car args)) 2)
  97              (string= (car args) "-T" :end1 2))
  98     (let ((arg (pop args)))
  99       (setf timing-out (if (= (length arg) 2) t
 100                            (subseq arg 2)))))
 101
 102   (let (t0 t1 t2)
 103     (setf t0 (get-internal-run-time)) ; warm cache
 104     (setf t0 (get-internal-run-time)) ; start time
 105     (setf t1 (get-internal-run-time)) ; overhead
 106     (flet ((hack-file (path)
 107              (cond ((string= path "-") (word-chain *standard-input*))
 108                    (t (with-open-file (stream path) (word-chain stream))))))
 109       (cond ((null args)
 110              (word-chain *standard-input*))
 111             ((null (cdr args))
 112              (hack-file (car args)))
 113             (t
 114              (dolist (arg args)
 115                (format t "~A: " arg)
 116                (hack-file arg)))))
 117     (setf t2 (get-internal-run-time)) ; final time
 118
 119     (flet ((write-time (stream)
 120              (format stream "~,3F~%"
 121                      (/ (max 0 (+ t2 t0 (* -2 t1)))
 122                         internal-time-units-per-second))))
 123       (cond ((eq timing-out t)
 124              (write-string ";; time = ")
 125              (write-time *standard-output*))
 126             (timing-out
 127              (with-open-file (stream timing-out
 128                               :direction :output
 129                               :if-does-not-exist :create
 130                               :if-exists :supersede)
 131                (write-time stream)))))))