Commit | Line | Data |
---|---|---|
2bd37ef1 MW |
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 | ||
851c7e3a MW |
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 | ||
2bd37ef1 MW |
25 | (defun list-iterator (iter) |
26 | "Collect the items from ITER into a list and return it." | |
851c7e3a MW |
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)))))) | |
2bd37ef1 MW |
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 | ||
9587c4d4 | 67 | (defun parse-tree (string &key (start 0) (end (length string))) |
2bd37ef1 MW |
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 | ||
9587c4d4 MW |
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))) | |
2bd37ef1 MW |
93 | |
94 | ;;;-------------------------------------------------------------------------- | |
95 | ;;; Main program. | |
96 | ||
23416a99 | 97 | (defun main (prog args) |
2bd37ef1 | 98 | "Main program: process ARGS." |
23416a99 MW |
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))))))) | |
4eee07ac MW |
114 | (simple-error (err) |
115 | (bail (simple-condition-format-control err) | |
116 | (simple-condition-format-arguments err))) | |
117 | (error (err) | |
23416a99 MW |
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*))) | |
2bd37ef1 MW |
135 | |
136 | ;;;----- That's all, folks -------------------------------------------------- |