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 list-iterator (iter)
  14   "Collect the items from ITER into a list and return it."
  15   (labels ((recur (iter list)
  16              (multiple-value-bind (data iter) (funcall iter)
  17                (if iter
  18                    (recur iter (cons data list))
  19                    (nreverse list)))))
  20     (recur iter nil)))
  21
  22 (defun same-iterators-p (iter-a iter-b &key (test #'eql))
  23   "Return whether ITER-A and ITER-B produce the same items."
  24   (labels ((recur (iter-a iter-b)
  25              (multiple-value-bind (data-a iter-a) (funcall iter-a)
  26                (multiple-value-bind (data-b iter-b) (funcall iter-b)
  27                  (cond ((null iter-a) (null iter-b))
  28                        ((or (null iter-b)
  29                             (not (funcall test data-a data-b)))
  30                         nil)
  31                        (t (recur iter-a iter-b)))))))
  32     (recur iter-a iter-b)))
  33
  34 ;;;--------------------------------------------------------------------------
  35 ;;; Nodes and trees.
  36
  37 (defstruct node
  38   "A simple node in a binary tree.  Empty subtrees are denoted by NIL."
  39   left data right)
  40
  41 (defun iterate-fringe (node)
  42   "Inorder iterator for the tree headed by NODE."
  43   (labels ((recur (node cont)
  44              (cond (node (recur (node-left node)
  45                                 (lambda ()
  46                                   (values (node-data node)
  47                                           (lambda ()
  48                                             (recur (node-right node)
  49                                                    cont))))))
  50                    (cont (funcall cont))
  51                    (t (values nil nil)))))
  52     (lambda () (recur node nil))))
  53
  54 (defun parse-tree (string)
  55   "Parse STRING, and return the tree described.
  56
  57    The syntax is simple:
  58
  59         tree ::= empty | `(' tree char tree `)'
  60
  61    The ambiguity is resolved by always treating `(' as a tree when a tree is
  62    expected."
  63
  64   (let ((len (length string)))
  65     (labels ((parse (i)
  66                (cond ((and (< i len) (char= (char string i) #\())
  67                       (multiple-value-bind (left i) (parse (1+ i))
  68                         (unless (< i len) (error "no data"))
  69                         (let ((data (char string i)))
  70                           (multiple-value-bind (right i) (parse (1+ i))
  71                             (unless (and (< i len)
  72                                          (char= (char string i) #\)))
  73                               (error "missing )"))
  74                             (values
  75                              (make-node :left left :data data :right right)
  76                              (1+ i))))))
  77                      (t (values nil i)))))
  78       (multiple-value-bind (tree i) (parse 0)
  79         (unless (= i len) (error "trailing junk"))
  80         tree))))
  81
  82 ;;;--------------------------------------------------------------------------
  83 ;;; Main program.
  84
  85 (defun main (args)
  86   "Main program: process ARGS."
  87   (destructuring-bind (&optional a b &rest junk) args
  88     (cond ((or (null a) junk) (error "bad args"))
  89           ((null b) (format t "~{~C~}~%"
  90                             (list-iterator (iterate-fringe (parse-tree a)))))
  91           (t (format t "~:[no match~;match~]~%"
  92                      (same-iterators-p (iterate-fringe (parse-tree a))
  93                                        (iterate-fringe (parse-tree b))))))))
  94
  95 #+cl-launch
  96 (progn
  97   (defparameter *program-name*
  98     (pathname-name (or (cl-launch:getenv "CL_LAUNCH_FILE")
  99                        (namestring *load-pathname*)
 100                        "<unknown>")))
 101   (defun launch ()
 102     (flet ((bail (format args)
 103              (format *error-output* "~A: ~?~%" *program-name* format args)
 104              (cl-launch:quit 1)))
 105       (handler-case
 106           (main cl-launch:*arguments*)
 107         (simple-error (err)
 108           (bail (simple-condition-format-control err)
 109                 (simple-condition-format-arguments err)))
 110         (error (err)
 111           (bail "~A" err))))))
 112
 113 ;;;----- That's all, folks --------------------------------------------------