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