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 | ||
67 | (defun parse-tree (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 | (let ((len (length string))) | |
78 | (labels ((parse (i) | |
d782cc40 | 79 | (cond ((and (< i len) (char= (char string i) #\()) |
2bd37ef1 MW |
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) #\))) | |
86 | (error "missing )")) | |
87 | (values | |
88 | (make-node :left left :data data :right right) | |
89 | (1+ i)))))) | |
90 | (t (values nil i))))) | |
91 | (multiple-value-bind (tree i) (parse 0) | |
92 | (unless (= i len) (error "trailing junk")) | |
93 | tree)))) | |
94 | ||
95 | ;;;-------------------------------------------------------------------------- | |
96 | ;;; Main program. | |
97 | ||
98 | (defun main (args) | |
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)))))))) | |
107 | ||
108 | #+cl-launch | |
4eee07ac MW |
109 | (progn |
110 | (defparameter *program-name* | |
111 | (pathname-name (or (cl-launch:getenv "CL_LAUNCH_FILE") | |
112 | (namestring *load-pathname*) | |
113 | "<unknown>"))) | |
114 | (defun launch () | |
115 | (flet ((bail (format args) | |
116 | (format *error-output* "~A: ~?~%" *program-name* format args) | |
117 | (cl-launch:quit 1))) | |
118 | (handler-case | |
119 | (main cl-launch:*arguments*) | |
120 | (simple-error (err) | |
121 | (bail (simple-condition-format-control err) | |
122 | (simple-condition-format-arguments err))) | |
123 | (error (err) | |
124 | (bail "~A" err)))))) | |
2bd37ef1 MW |
125 | |
126 | ;;;----- That's all, folks -------------------------------------------------- |