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 ((>= i len)
  67                       (values nil i))
  68                      ((char= (char string i) #\()
  69                       (multiple-value-bind (left i) (parse (1+ i))
  70                         (unless (< i len) (error "no data"))
  71                         (let ((data (char string i)))
  72                           (multiple-value-bind (right i) (parse (1+ i))
  73                             (unless (and (< i len)
  74                                          (char= (char string i) #\)))
  75                               (error "missing )"))
  76                             (values
  77                              (make-node :left left :data data :right right)
  78                              (1+ i))))))
  79                      (t (values nil i)))))
  80       (multiple-value-bind (tree i) (parse 0)
  81         (unless (= i len) (error "trailing junk"))
  82         tree))))
  83
  84 ;;;--------------------------------------------------------------------------
  85 ;;; Main program.
  86
  87 (defun main (args)
  88   "Main program: process ARGS."
  89   (destructuring-bind (&optional a b &rest junk) args
  90     (cond ((or (null a) junk) (error "bad args"))
  91           ((null b) (format t "~{~C~}~%"
  92                             (list-iterator (iterate-fringe (parse-tree a)))))
  93           (t (format t "~:[no match~;match~]~%"
  94                      (same-iterators-p (iterate-fringe (parse-tree a))
  95                                        (iterate-fringe (parse-tree b))))))))
  96
  97 #+cl-launch
  98 (flet ((bail (format args)
  99          (format *error-output* "~A: ~?~%"
 100                  (cl-launch:getenv "CL_LAUNCH_FILE") format args)
 101          (cl-launch:quit 1)))
 102   (handler-case
 103       (main cl-launch:*arguments*)
 104     (simple-error (err)
 105       (bail (simple-condition-format-control err)
 106             (simple-condition-format-arguments err)))
 107     (error (err)
 108       (bail "~A" err))))
 109
 110 ;;;----- That's all, folks --------------------------------------------------