chiark - git - mdw - 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 &key (start 0) (end (length 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   (labels ((parse (i)
  78              (cond ((and (< i end) (char= (char string i) #\())
  79                     (multiple-value-bind (left i) (parse (1+ i))
  80                       (unless (< i end) (error "no data"))
  81                       (let ((data (char string i)))
  82                         (multiple-value-bind (right i) (parse (1+ i))
  83                           (unless (and (< i end)
  84                                        (char= (char string i) #\)))
  85                             (error "missing )"))
  86                           (values
  87                            (make-node :left left :data data :right right)
  88                            (1+ i))))))
  89                    (t (values nil i)))))
  90     (multiple-value-bind (tree i) (parse start)
  91       (unless (= i end) (error "trailing junk"))
  92       tree)))
  93
  94 ;;;--------------------------------------------------------------------------
  95 ;;; Main program.
  96
  97 (defun main (prog args)
  98   "Main program: process ARGS."
  99   (flet ((bail (format args)
 100            (format *error-output* "~A: ~?~%" prog format args)
 101            (return-from main 1)))
 102     (handler-case
 103         (destructuring-bind (&optional a b &rest junk) args
 104           (cond ((or (null a) junk)
 105                  (error "bad args"))
 106                 ((null b)
 107                  (format t "~{~C~}~%"
 108                          (list-iterator (iterate-fringe (parse-tree a)))))
 109                 (t
 110                  (format t "~:[no match~;match~]~%"
 111                          (same-iterators-p
 112                           (iterate-fringe (parse-tree a))
 113                           (iterate-fringe (parse-tree b)))))))
 114         (simple-error (err)
 115           (bail (simple-condition-format-control err)
 116                 (simple-condition-format-arguments err)))
 117         (error (err)
 118           (bail "~A" err)))
 119     0))
 120
 121 #+cl-launch
 122 (defun launch ()
 123   (cl-launch:quit (main (or (cl-launch:getenv "CL_LAUNCH_FILE")
 124                             (namestring *load-pathname*)
 125                             "<unknown>")
 126                         cl-launch:*arguments*)))
 127
 128 #+(and (not cl-launch) ecl)
 129 (ext:quit (main (ext:argv 0)
 130                 (loop for i from 1 below (ext:argc) collect (ext:argv i))))
 131
 132 #+(and (not cl-launch) sbcl)
 133 (sb-ext:quit :unix-status (main (pathname-name *load-pathname*)
 134                                 (cdr sb-ext:*posix-argv*)))
 135
 136 ;;;----- That's all, folks --------------------------------------------------