mdw@git.distorted.org.uk Git - fringe/blob - cl-fringe.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Lisp implementation of a `same-fringe' solver.
   4
   5 ;;;--------------------------------------------------------------------------
   6 ;;; Iteration utilities.
   7
   8 ;; The iteration protocol is as follows.  An iterator is simply a function
   9 ;; invoked with no arguments.  It returns two values: the next item, and a
  10 ;; new iterator function to produce the remaining items; if there are no more
  11 ;; items, then it returns NIL twice.
  12
  13 (defun reduce-iterator (func init iter)
  14   "Invoke FUNC on the elements of ITER.
  15
  16    We maintain a STATE whose value initially is INIT; for each ITEM, we
  17    update the state with the value of (funcall FUNC ITEM STATE); the end
  18    result is the final state."
  19   (let ((state init) item)
  20     (loop
  21       (setf (values item iter) (funcall iter))
  22       (unless iter (return state))
  23       (setf state (funcall func item state)))))
  24
  25 (defun list-iterator (iter)
  26   "Collect the items from ITER into a list and return it."
  27   (nreverse (reduce-iterator #'cons nil iter)))
  28
  29 (defun iterate-list (list)
  30   "Return an iterator for LIST, according to our iteration protocol."
  31   (if (endp list)
  32       (lambda () (values nil nil))
  33       (lambda () (values (car list) (iterate-list (cdr list))))))
  34
  35 (defun same-iterators-p (iter-a iter-b &key (test #'eql))
  36   "Return whether ITER-A and ITER-B produce the same items."
  37   (labels ((recur (iter-a iter-b)
  38              (multiple-value-bind (data-a iter-a) (funcall iter-a)
  39                (multiple-value-bind (data-b iter-b) (funcall iter-b)
  40                  (cond ((null iter-a) (null iter-b))
  41                        ((or (null iter-b)
  42                             (not (funcall test data-a data-b)))
  43                         nil)
  44                        (t (recur iter-a iter-b)))))))
  45     (recur iter-a iter-b)))
  46
  47 ;;;--------------------------------------------------------------------------
  48 ;;; Nodes and trees.
  49
  50 (defstruct node
  51   "A simple node in a binary tree.  Empty subtrees are denoted by NIL."
  52   left data right)
  53
  54 (defun iterate-fringe (node)
  55   "Inorder iterator for the tree headed by NODE."
  56   (labels ((recur (node cont)
  57              (cond (node (recur (node-left node)
  58                                 (lambda ()
  59                                   (values (node-data node)
  60                                           (lambda ()
  61                                             (recur (node-right node)
  62                                                    cont))))))
  63                    (cont (funcall cont))
  64                    (t (values nil nil)))))
  65     (lambda () (recur node nil))))
  66
  67 (defun parse-tree (string)
  68   "Parse STRING, and return the tree described.
  69
  70    The syntax is simple:
  71
  72         tree ::= empty | `(' tree char tree `)'
  73
  74    The ambiguity is resolved by always treating `(' as a tree when a tree is
  75    expected."
  76
  77   (let ((len (length string)))
  78     (labels ((parse (i)
  79                (cond ((and (< i len) (char= (char string i) #\())
  80                       (multiple-value-bind (left i) (parse (1+ i))
  81                         (unless (< i len) (error "no data"))
  82                         (let ((data (char string i)))
  83                           (multiple-value-bind (right i) (parse (1+ i))
  84                             (unless (and (< i len)
  85                                          (char= (char string i) #\)))
  86                               (error "missing )"))
  87                             (values
  88                              (make-node :left left :data data :right right)
  89                              (1+ i))))))
  90                      (t (values nil i)))))
  91       (multiple-value-bind (tree i) (parse 0)
  92         (unless (= i len) (error "trailing junk"))
  93         tree))))
  94
  95 ;;;--------------------------------------------------------------------------
  96 ;;; Main program.
  97
  98 (defun main (prog args)
  99   "Main program: process ARGS."
 100   (flet ((bail (format args)
 101            (format *error-output* "~A: ~?~%" prog format args)
 102            (return-from main 1)))
 103     (handler-case
 104         (destructuring-bind (&optional a b &rest junk) args
 105           (cond ((or (null a) junk)
 106                  (error "bad args"))
 107                 ((null b)
 108                  (format t "~{~C~}~%"
 109                          (list-iterator (iterate-fringe (parse-tree a)))))
 110                 (t
 111                  (format t "~:[no match~;match~]~%"
 112                          (same-iterators-p
 113                           (iterate-fringe (parse-tree a))
 114                           (iterate-fringe (parse-tree b)))))))
 115         (simple-error (err)
 116           (bail (simple-condition-format-control err)
 117                 (simple-condition-format-arguments err)))
 118         (error (err)
 119           (bail "~A" err)))
 120     0))
 121
 122 #+cl-launch
 123 (defun launch ()
 124   (cl-launch:quit (main (or (cl-launch:getenv "CL_LAUNCH_FILE")
 125                             (namestring *load-pathname*)
 126                             "<unknown>")
 127                         cl-launch:*arguments*)))
 128
 129 #+(and (not cl-launch) ecl)
 130 (ext:quit (main (ext:argv 0)
 131                 (loop for i from 1 below (ext:argc) collect (ext:argv i))))
 132
 133 #+(and (not cl-launch) sbcl)
 134 (sb-ext:quit :unix-status (main (pathname-name *load-pathname*)
 135                                 (cdr sb-ext:*posix-argv*)))
 136
 137 ;;;----- That's all, folks --------------------------------------------------