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