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 ;;;--------------------------------------------------------------------------
98 (defun main (prog args)
99 "Main program: process ARGS."
100 (flet ((bail (format args)
101 (format *error-output* "~A: ~?~%" prog format args)
102 (return-from main 1)))
104 (destructuring-bind (&optional a b &rest junk) args
105 (cond ((or (null a) junk)
109 (list-iterator (iterate-fringe (parse-tree a)))))
111 (format t "~:[no match~;match~]~%"
113 (iterate-fringe (parse-tree a))
114 (iterate-fringe (parse-tree b)))))))
116 (bail (simple-condition-format-control err)
117 (simple-condition-format-arguments err)))
124 (cl-launch:quit (main (or (cl-launch:getenv "CL_LAUNCH_FILE")
125 (namestring *load-pathname*)
127 cl-launch:*arguments*)))
129 #+(and (not cl-launch) ecl)
130 (ext:quit (main (ext:argv 0)
131 (loop for i from 1 below (ext:argc) collect (ext:argv i))))
133 #+(and (not cl-launch) sbcl)
134 (sb-ext:quit :unix-status (main (pathname-name *load-pathname*)
135 (cdr sb-ext:*posix-argv*)))
137 ;;;----- That's all, folks --------------------------------------------------