| 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 -------------------------------------------------- |