3 ;;; Scheme implementation of a `same-fringe' solver. Assumes Chicken, but
4 ;;; should port easily.
6 ;;;--------------------------------------------------------------------------
9 (define-syntax with-values
10 ;; Bind the values returned by FORM to the VARS and evaluate BODY.
13 ((with-values vars form . body)
14 (call-with-values (lambda () form)
16 (apply (lambda vars . body) stuff))))))
19 ;; If CONDITION is not #f then evaluate BODY.
22 ((when condition . body)
23 (if condition (begin . body)))))
26 ;; If CONDITION is #f then evaluate BODY.
29 ((unless condition . body)
30 (if (not condition) (begin . body)))))
32 ;;;--------------------------------------------------------------------------
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)
40 (continuation %coroutine-continuation %set-coroutine-continuation!))
42 (define %current-coroutine (make-coroutine #f))
43 (define (current-coroutine)
44 ;; Return the current coroutine.
47 (define %calling-coroutine #f)
48 (define (calling-coroutine)
49 ;; Return the coroutine that invoked the current one. Before any switch,
53 (define (resume coroutine . args)
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.
59 (call-with-current-continuation
61 (%set-coroutine-continuation! %current-coroutine k)
62 (set! %calling-coroutine %current-coroutine)
63 (set! %current-coroutine coroutine)
64 (apply (%coroutine-continuation coroutine) args))))
66 ;;;--------------------------------------------------------------------------
69 (define-syntax define-generator
70 ;; Define a function returning a generator. The generator yields whatever
71 ;; the function body does.
74 ((define-generator (name . args) . body)
76 (make-coroutine (lambda ()
78 (resume (calling-coroutine) #f #f)))))))
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
85 (with-values () (resume (calling-coroutine) object #t) #f))
87 (define (reduce-generator func init gen)
88 ;; Call FUNC for each item in the generator GEN.
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.
94 (let loop ((state init))
95 (with-values (item any?) (resume gen)
97 (loop (func item state))
100 (define (list-generator gen)
101 ;; Collect the elements generated by GEN into a list and return it.
103 (reverse (reduce-generator cons '() gen)))
105 (define (same-generators? gen-a gen-b)
106 ;; Return whether GEN-A and GEN-B generate the same elements in the same
110 (with-values (a any-a?) (resume gen-a)
111 (with-values (b any-b?) (resume gen-b)
112 (cond ((not any-a?) (not any-b?))
117 ;;;--------------------------------------------------------------------------
120 ;; Assumes SRFI-9; widely available.
121 (define-record-type node
122 ;; A node in a simple binary tree. Empty subtrees are denoted by ().
124 (make-node left data right)
130 (define-generator (fringe node)
131 ;; Generate the elements of the tree headed by NODE inorder.
133 (let recur ((node node))
135 (recur (node-left node))
136 (yield (node-data node))
137 (recur (node-right node)))))
139 (define (parse-tree string)
140 ;; Return a tree constructed according to STRING.
144 ;; tree ::= empty | `(' tree char tree `)'
146 ;; disambiguated by treating `(' as starting a tree wherever a tree is
149 (let ((len (string-length string)))
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) #\)))
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"))
165 ;;;--------------------------------------------------------------------------
169 (cond ((null? args) (error "bad args"))
171 (reduce-generator (lambda (ch ?) (write-char ch)) #f
172 (fringe (parse-tree (car args))))
175 (display (if (same-generators? (fringe (parse-tree (car args)))
176 (fringe (parse-tree (cadr args))))
180 (else (error "bad args"))))
182 ;; Chicken-specific (works in interpreter and standalone compiled code).
183 (let ((program (car (argv))))
184 (condition-case (begin (main (command-line-arguments)) (exit))
186 (print-error-message err (current-error-port) program)
189 ;;;----- That's all, folks --------------------------------------------------