Commit | Line | Data |
---|---|---|
2bd37ef1 MW |
1 | ;;; -*-scheme-*- |
2 | ;;; | |
3 | ;;; Scheme implementation of a `same-fringe' solver. Assumes Chicken, but | |
4 | ;;; should port easily. | |
5 | ||
2bd37ef1 MW |
6 | ;;;-------------------------------------------------------------------------- |
7 | ;;; Utilities. | |
8 | ||
9 | (define-syntax with-values | |
10 | ;; Bind the values returned by FORM to the VARS and evaluate BODY. | |
11 | ||
12 | (syntax-rules () | |
13 | ((with-values vars form . body) | |
14 | (call-with-values (lambda () form) | |
15 | (lambda stuff | |
16 | (apply (lambda vars . body) stuff)))))) | |
17 | ||
18 | (define-syntax when | |
19 | ;; If CONDITION is not #f then evaluate BODY. | |
20 | ||
21 | (syntax-rules () | |
22 | ((when condition . body) | |
23 | (if condition (begin . body))))) | |
24 | ||
25 | (define-syntax unless | |
26 | ;; If CONDITION is #f then evaluate BODY. | |
27 | ||
28 | (syntax-rules () | |
29 | ((unless condition . body) | |
30 | (if (not condition) (begin . body))))) | |
31 | ||
32 | ;;;-------------------------------------------------------------------------- | |
33 | ;;; Coroutines. | |
34 | ||
35 | (define-record-type coroutine | |
36 | ;; A coroutine simply remembers the continuaton which was suspended when it | |
37 | ;; last invoked a different coroutine. | |
38 | (make-coroutine continuation) | |
39 | coroutine? | |
40 | (continuation %coroutine-continuation %set-coroutine-continuation!)) | |
41 | ||
42 | (define %current-coroutine (make-coroutine #f)) | |
43 | (define (current-coroutine) | |
44 | ;; Return the current coroutine. | |
45 | %current-coroutine) | |
46 | ||
47 | (define %calling-coroutine #f) | |
48 | (define (calling-coroutine) | |
49 | ;; Return the coroutine that invoked the current one. Before any switch, | |
50 | ;; this is #f. | |
51 | %calling-coroutine) | |
52 | ||
652d4a58 | 53 | (define (resume coroutine . args) |
2bd37ef1 MW |
54 | ;; Switch to COROUTINE, passing it ARGS. When this coroutine is resumed |
55 | ;; (by calling `switch', naturally) it will return the values passed as | |
56 | ;; arguments. A new coroutine (made by `make-coroutine') receives these | |
57 | ;; values as its arguments. | |
58 | ||
59 | (call-with-current-continuation | |
60 | (lambda (k) | |
61 | (%set-coroutine-continuation! %current-coroutine k) | |
62 | (set! %calling-coroutine %current-coroutine) | |
63 | (set! %current-coroutine coroutine) | |
64 | (apply (%coroutine-continuation coroutine) args)))) | |
65 | ||
66 | ;;;-------------------------------------------------------------------------- | |
67 | ;;; Generators. | |
68 | ||
69 | (define-syntax define-generator | |
70 | ;; Define a function returning a generator. The generator yields whatever | |
71 | ;; the function body does. | |
72 | ||
73 | (syntax-rules () | |
74 | ((define-generator (name . args) . body) | |
75 | (define (name . args) | |
76 | (make-coroutine (lambda () | |
226de6c6 MW |
77 | (begin . body) |
78 | (resume (calling-coroutine) #f #f))))))) | |
2bd37ef1 MW |
79 | |
80 | (define (yield object) | |
81 | ;; Yield OBJECT from a generator. The generator protocol returns two | |
82 | ;; values each time: either an object and #t, or #f twice to mark the end | |
83 | ;; of the sequence. | |
84 | ||
652d4a58 | 85 | (with-values () (resume (calling-coroutine) object #t) #f)) |
2bd37ef1 | 86 | |
851c7e3a MW |
87 | (define (reduce-generator func init gen) |
88 | ;; Call FUNC for each item in the generator GEN. | |
89 | ;; | |
90 | ;; We maintain a STATE, which is initially INIT. For each ITEM produced by | |
91 | ;; the generator, we replace the state by (FUNC ITEM STATE); finally, we | |
92 | ;; return the final state. | |
93 | ||
94 | (let loop ((state init)) | |
95 | (with-values (item any?) (resume gen) | |
96 | (if any? | |
97 | (loop (func item state)) | |
98 | state)))) | |
99 | ||
2bd37ef1 MW |
100 | (define (list-generator gen) |
101 | ;; Collect the elements generated by GEN into a list and return it. | |
102 | ||
851c7e3a | 103 | (reverse (reduce-generator cons '() gen))) |
2bd37ef1 MW |
104 | |
105 | (define (same-generators? gen-a gen-b) | |
106 | ;; Return whether GEN-A and GEN-B generate the same elements in the same | |
107 | ;; order. | |
108 | ||
109 | (let loop () | |
652d4a58 MW |
110 | (with-values (a any-a?) (resume gen-a) |
111 | (with-values (b any-b?) (resume gen-b) | |
2bd37ef1 MW |
112 | (cond ((not any-a?) (not any-b?)) |
113 | ((not any-b?) #f) | |
114 | ((eqv? a b) (loop)) | |
115 | (else #f)))))) | |
116 | ||
117 | ;;;-------------------------------------------------------------------------- | |
118 | ;;; Nodes and trees. | |
119 | ||
120 | ;; Assumes SRFI-9; widely available. | |
121 | (define-record-type node | |
122 | ;; A node in a simple binary tree. Empty subtrees are denoted by (). | |
123 | ||
124 | (make-node left data right) | |
125 | node? | |
126 | (left node-left) | |
127 | (data node-data) | |
128 | (right node-right)) | |
129 | ||
130 | (define-generator (fringe node) | |
131 | ;; Generate the elements of the tree headed by NODE inorder. | |
132 | ||
133 | (let recur ((node node)) | |
134 | (unless (null? node) | |
135 | (recur (node-left node)) | |
136 | (yield (node-data node)) | |
137 | (recur (node-right node))))) | |
138 | ||
139 | (define (parse-tree string) | |
140 | ;; Return a tree constructed according to STRING. | |
141 | ;; | |
142 | ;; Syntax is: | |
143 | ;; | |
144 | ;; tree ::= empty | `(' tree char tree `)' | |
145 | ;; | |
146 | ;; disambiguated by treating `(' as starting a tree wherever a tree is | |
147 | ;; expected. | |
148 | ||
149 | (let ((len (string-length string))) | |
150 | (define (parse i) | |
151 | (cond ((>= i len) (values '() i)) | |
152 | ((char=? (string-ref string i) #\() | |
153 | (with-values (left i) (parse (+ 1 i)) | |
154 | (unless (< i len) (error "no data")) | |
155 | (let ((data (string-ref string i))) | |
156 | (with-values (right i) (parse (+ 1 i)) | |
157 | (unless (and (< i len) (char=? (string-ref string i) #\))) | |
158 | (error "missing )")) | |
159 | (values (make-node left data right) (+ 1 i)))))) | |
160 | (else (values '() i)))) | |
161 | (with-values (tree i) (parse 0) | |
162 | (unless (= i len) (error "trailing junk")) | |
163 | tree))) | |
164 | ||
165 | ;;;-------------------------------------------------------------------------- | |
166 | ;;; Main program. | |
167 | ||
168 | (define (main args) | |
169 | (cond ((null? args) (error "bad args")) | |
170 | ((null? (cdr args)) | |
851c7e3a MW |
171 | (reduce-generator (lambda (ch ?) (write-char ch)) #f |
172 | (fringe (parse-tree (car args)))) | |
2bd37ef1 MW |
173 | (newline)) |
174 | ((null? (cddr args)) | |
175 | (display (if (same-generators? (fringe (parse-tree (car args))) | |
176 | (fringe (parse-tree (cadr args)))) | |
177 | "match" | |
178 | "no match")) | |
179 | (newline)) | |
180 | (else (error "bad args")))) | |
181 | ||
182 | ;; Chicken-specific (works in interpreter and standalone compiled code). | |
183 | (let ((program (car (argv)))) | |
184 | (condition-case (begin (main (command-line-arguments)) (exit)) | |
185 | (err (exn) | |
186 | (print-error-message err (current-error-port) program) | |
187 | (exit 1)))) | |
188 | ||
189 | ;;;----- That's all, folks -------------------------------------------------- |