3 ;;; Lisp implementation of a `same-fringe' solver.
5 ;;;--------------------------------------------------------------------------
6 ;;; Iteration utilities.
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.
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)
18 (recur iter (cons data list))
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))
29 (not (funcall test data-a data-b)))
31 (t (recur iter-a iter-b)))))))
32 (recur iter-a iter-b)))
34 ;;;--------------------------------------------------------------------------
38 "A simple node in a binary tree. Empty subtrees are denoted by NIL."
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)
46 (values (node-data node)
48 (recur (node-right node)
51 (t (values nil nil)))))
52 (lambda () (recur node nil))))
54 (defun parse-tree (string)
55 "Parse STRING, and return the tree described.
59 tree ::= empty | `(' tree char tree `)'
61 The ambiguity is resolved by always treating `(' as a tree when a tree is
64 (let ((len (length string)))
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) #\)))
75 (make-node :left left :data data :right right)
78 (multiple-value-bind (tree i) (parse 0)
79 (unless (= i len) (error "trailing junk"))
82 ;;;--------------------------------------------------------------------------
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))))))))
97 (defparameter *program-name*
98 (pathname-name (or (cl-launch:getenv "CL_LAUNCH_FILE")
99 (namestring *load-pathname*)
102 (flet ((bail (format args)
103 (format *error-output* "~A: ~?~%" *program-name* format args)
106 (main cl-launch:*arguments*)
108 (bail (simple-condition-format-control err)
109 (simple-condition-format-arguments err)))
113 ;;;----- That's all, folks --------------------------------------------------