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 MW |
88 | |
89 | (define (list-generator gen) | |
90 | ;; Collect the elements generated by GEN into a list and return it. | |
91 | ||
92 | (let loop ((l '())) | |
652d4a58 | 93 | (with-values (it any?) (resume gen) |
2bd37ef1 MW |
94 | (if any? |
95 | (loop (cons it l)) | |
96 | (reverse l))))) | |
97 | ||
98 | (define (same-generators? gen-a gen-b) | |
99 | ;; Return whether GEN-A and GEN-B generate the same elements in the same | |
100 | ;; order. | |
101 | ||
102 | (let loop () | |
652d4a58 MW |
103 | (with-values (a any-a?) (resume gen-a) |
104 | (with-values (b any-b?) (resume gen-b) | |
2bd37ef1 MW |
105 | (cond ((not any-a?) (not any-b?)) |
106 | ((not any-b?) #f) | |
107 | ((eqv? a b) (loop)) | |
108 | (else #f)))))) | |
109 | ||
110 | ;;;-------------------------------------------------------------------------- | |
111 | ;;; Nodes and trees. | |
112 | ||
113 | ;; Assumes SRFI-9; widely available. | |
114 | (define-record-type node | |
115 | ;; A node in a simple binary tree. Empty subtrees are denoted by (). | |
116 | ||
117 | (make-node left data right) | |
118 | node? | |
119 | (left node-left) | |
120 | (data node-data) | |
121 | (right node-right)) | |
122 | ||
123 | (define-generator (fringe node) | |
124 | ;; Generate the elements of the tree headed by NODE inorder. | |
125 | ||
126 | (let recur ((node node)) | |
127 | (unless (null? node) | |
128 | (recur (node-left node)) | |
129 | (yield (node-data node)) | |
130 | (recur (node-right node))))) | |
131 | ||
132 | (define (parse-tree string) | |
133 | ;; Return a tree constructed according to STRING. | |
134 | ;; | |
135 | ;; Syntax is: | |
136 | ;; | |
137 | ;; tree ::= empty | `(' tree char tree `)' | |
138 | ;; | |
139 | ;; disambiguated by treating `(' as starting a tree wherever a tree is | |
140 | ;; expected. | |
141 | ||
142 | (let ((len (string-length string))) | |
143 | (define (parse i) | |
144 | (cond ((>= i len) (values '() i)) | |
145 | ((char=? (string-ref string i) #\() | |
146 | (with-values (left i) (parse (+ 1 i)) | |
147 | (unless (< i len) (error "no data")) | |
148 | (let ((data (string-ref string i))) | |
149 | (with-values (right i) (parse (+ 1 i)) | |
150 | (unless (and (< i len) (char=? (string-ref string i) #\))) | |
151 | (error "missing )")) | |
152 | (values (make-node left data right) (+ 1 i)))))) | |
153 | (else (values '() i)))) | |
154 | (with-values (tree i) (parse 0) | |
155 | (unless (= i len) (error "trailing junk")) | |
156 | tree))) | |
157 | ||
158 | ;;;-------------------------------------------------------------------------- | |
159 | ;;; Main program. | |
160 | ||
161 | (define (main args) | |
162 | (cond ((null? args) (error "bad args")) | |
163 | ((null? (cdr args)) | |
164 | (do ((l (list-generator (fringe (parse-tree (car args)))) (cdr l))) | |
165 | ((null? l)) | |
166 | (write-char (car l))) | |
167 | (newline)) | |
168 | ((null? (cddr args)) | |
169 | (display (if (same-generators? (fringe (parse-tree (car args))) | |
170 | (fringe (parse-tree (cadr args)))) | |
171 | "match" | |
172 | "no match")) | |
173 | (newline)) | |
174 | (else (error "bad args")))) | |
175 | ||
176 | ;; Chicken-specific (works in interpreter and standalone compiled code). | |
177 | (let ((program (car (argv)))) | |
178 | (condition-case (begin (main (command-line-arguments)) (exit)) | |
179 | (err (exn) | |
180 | (print-error-message err (current-error-port) program) | |
181 | (exit 1)))) | |
182 | ||
183 | ;;;----- That's all, folks -------------------------------------------------- |