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 reduce-iterator (func init iter)
14 "Invoke FUNC on the elements of ITER.
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)
21 (setf (values item iter) (funcall iter))
22 (unless iter (return state))
23 (setf state (funcall func item state)))))
25 (defun list-iterator (iter)
26 "Collect the items from ITER into a list and return it."
27 (nreverse (reduce-iterator #'cons nil iter)))
29 (defun iterate-list (list)
30 "Return an iterator for LIST, according to our iteration protocol."
32 (lambda () (values nil nil))
33 (lambda () (values (car list) (iterate-list (cdr list))))))
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))
42 (not (funcall test data-a data-b)))
44 (t (recur iter-a iter-b)))))))
45 (recur iter-a iter-b)))
47 ;;;--------------------------------------------------------------------------
51 "A simple node in a binary tree. Empty subtrees are denoted by NIL."
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)
59 (values (node-data node)
61 (recur (node-right node)
64 (t (values nil nil)))))
65 (lambda () (recur node nil))))
67 (defun parse-tree (string)
68 "Parse STRING, and return the tree described.
72 tree ::= empty | `(' tree char tree `)'
74 The ambiguity is resolved by always treating `(' as a tree when a tree is
77 (let ((len (length string)))
79 (cond ((and (< i len) (char= (char string i) #\())
80 (multiple-value-bind (left i) (parse (1+ i))
81 (unless (< i len) (error "no data"))
82 (let ((data (char string i)))
83 (multiple-value-bind (right i) (parse (1+ i))
84 (unless (and (< i len)
85 (char= (char string i) #\)))
88 (make-node :left left :data data :right right)
91 (multiple-value-bind (tree i) (parse 0)
92 (unless (= i len) (error "trailing junk"))
95 ;;;--------------------------------------------------------------------------
99 "Main program: process ARGS."
100 (destructuring-bind (&optional a b &rest junk) args
101 (cond ((or (null a) junk) (error "bad args"))
102 ((null b) (format t "~{~C~}~%"
103 (list-iterator (iterate-fringe (parse-tree a)))))
104 (t (format t "~:[no match~;match~]~%"
105 (same-iterators-p (iterate-fringe (parse-tree a))
106 (iterate-fringe (parse-tree b))))))))
110 (defparameter *program-name*
111 (pathname-name (or (cl-launch:getenv "CL_LAUNCH_FILE")
112 (namestring *load-pathname*)
115 (flet ((bail (format args)
116 (format *error-output* "~A: ~?~%" *program-name* format args)
119 (main cl-launch:*arguments*)
121 (bail (simple-condition-format-control err)
122 (simple-condition-format-arguments err)))
126 ;;;----- That's all, folks --------------------------------------------------