;;; -*-lisp-*-

(defstruct (node (:predicate nodep)
		 (:constructor make-node (word)))
  (word (error "uninitialized slot") :type string :read-only t)
  (len 0 :type fixnum)
  (up nil :type (or node null))
  (down nil :type (or node null))
  (right nil :type (or node null)))

(defun word-chain (stream)
  (declare (optimize speed))

  (let ((map (make-hash-table :test #'equal))
	(max 0) (winners nil))

    (loop
      (let ((line (read-line stream nil)))
	(unless line (return))
	(setf (gethash line map) (make-node line))))

    (maphash (lambda (word node)
	       (declare (type string word)
			(type node node))

	       ;;(format t ";; contemplate `~A'~%" word)
	       (let ((parent (let ((len (length word)))
			       (and (>= len 1)
				    (gethash (subseq word 0 (1- len))
					     map))))
		     (nlen (node-len node)))
		 (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)

    (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))
      (timing-out nil))

  (handler-bind ((warning #'muffle-warning))
    (let ((*compile-verbose* nil))
      (compile 'word-chain)))

  (when (and args (>= (length (car args)) 2)
	     (string= (car args) "-T" :end1 2))
    (let ((arg (pop args)))
      (setf timing-out (if (= (length arg) 2) t
			   (subseq arg 2)))))

  (let (t0 t1 t2)
    (setf t0 (get-internal-run-time)) ; warm cache
    (setf t0 (get-internal-run-time)) ; start time
    (setf t1 (get-internal-run-time)) ; overhead
    (flet ((hack-file (path)
	     (cond ((string= path "-") (word-chain *standard-input*))
		   (t (with-open-file (stream path) (word-chain stream))))))
      (cond ((null args)
	     (word-chain *standard-input*))
	    ((null (cdr args))
	     (hack-file (car args)))
	    (t
	     (dolist (arg args)
	       (format t "~A: " arg)
	       (hack-file arg)))))
    (setf t2 (get-internal-run-time)) ; final time

    (flet ((write-time (stream)
	     (format stream "~,3F~%"
		     (/ (max 0 (+ t2 t0 (* -2 t1)))
			internal-time-units-per-second))))
      (cond ((eq timing-out t)
	     (write-string ";; time = ")
	     (write-time *standard-output*))
	    (timing-out
	     (with-open-file (stream timing-out
			      :direction :output
			      :if-does-not-exist :create
			      :if-exists :supersede)
	       (write-time stream)))))))