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 | ||
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) | |
17 | (if iter | |
18 | (recur iter (cons data list)) | |
19 | (nreverse list))))) | |
20 | (recur iter nil))) | |
21 | ||
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)) | |
28 | ((or (null iter-b) | |
29 | (not (funcall test data-a data-b))) | |
30 | nil) | |
31 | (t (recur iter-a iter-b))))))) | |
32 | (recur iter-a iter-b))) | |
33 | ||
34 | ;;;-------------------------------------------------------------------------- | |
35 | ;;; Nodes and trees. | |
36 | ||
37 | (defstruct node | |
38 | "A simple node in a binary tree. Empty subtrees are denoted by NIL." | |
39 | left data right) | |
40 | ||
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) | |
45 | (lambda () | |
46 | (values (node-data node) | |
47 | (lambda () | |
48 | (recur (node-right node) | |
49 | cont)))))) | |
50 | (cont (funcall cont)) | |
51 | (t (values nil nil))))) | |
52 | (lambda () (recur node nil)))) | |
53 | ||
54 | (defun parse-tree (string) | |
55 | "Parse STRING, and return the tree described. | |
56 | ||
57 | The syntax is simple: | |
58 | ||
59 | tree ::= empty | `(' tree char tree `)' | |
60 | ||
61 | The ambiguity is resolved by always treating `(' as a tree when a tree is | |
62 | expected." | |
63 | ||
64 | (let ((len (length string))) | |
65 | (labels ((parse (i) | |
66 | (cond ((>= i len) | |
67 | (values nil i)) | |
68 | ((char= (char string i) #\() | |
69 | (multiple-value-bind (left i) (parse (1+ i)) | |
70 | (unless (< i len) (error "no data")) | |
71 | (let ((data (char string i))) | |
72 | (multiple-value-bind (right i) (parse (1+ i)) | |
73 | (unless (and (< i len) | |
74 | (char= (char string i) #\))) | |
75 | (error "missing )")) | |
76 | (values | |
77 | (make-node :left left :data data :right right) | |
78 | (1+ i)))))) | |
79 | (t (values nil i))))) | |
80 | (multiple-value-bind (tree i) (parse 0) | |
81 | (unless (= i len) (error "trailing junk")) | |
82 | tree)))) | |
83 | ||
84 | ;;;-------------------------------------------------------------------------- | |
85 | ;;; Main program. | |
86 | ||
87 | (defun main (args) | |
88 | "Main program: process ARGS." | |
89 | (destructuring-bind (&optional a b &rest junk) args | |
90 | (cond ((or (null a) junk) (error "bad args")) | |
91 | ((null b) (format t "~{~C~}~%" | |
92 | (list-iterator (iterate-fringe (parse-tree a))))) | |
93 | (t (format t "~:[no match~;match~]~%" | |
94 | (same-iterators-p (iterate-fringe (parse-tree a)) | |
95 | (iterate-fringe (parse-tree b)))))))) | |
96 | ||
97 | #+cl-launch | |
a72b6978 MW |
98 | (defun launch () |
99 | (flet ((bail (format args) | |
100 | (format *error-output* "~A: ~?~%" | |
101 | (cl-launch:getenv "CL_LAUNCH_FILE") format args) | |
102 | (cl-launch:quit 1))) | |
103 | (handler-case | |
104 | (main cl-launch:*arguments*) | |
105 | (simple-error (err) | |
106 | (bail (simple-condition-format-control err) | |
107 | (simple-condition-format-arguments err))) | |
108 | (error (err) | |
109 | (bail "~A" err))))) | |
2bd37ef1 MW |
110 | |
111 | ;;;----- That's all, folks -------------------------------------------------- |