3 ;;; Scheme implementation of a `same-fringe' solver. Assumes Chicken, but
4 ;;; should port easily.
6 (use syntax-case) ; Chicken-specfic
8 ;;;--------------------------------------------------------------------------
11 (define-syntax with-values
12 ;; Bind the values returned by FORM to the VARS and evaluate BODY.
15 ((with-values vars form . body)
16 (call-with-values (lambda () form)
18 (apply (lambda vars . body) stuff))))))
21 ;; If CONDITION is not #f then evaluate BODY.
24 ((when condition . body)
25 (if condition (begin . body)))))
28 ;; If CONDITION is #f then evaluate BODY.
31 ((unless condition . body)
32 (if (not condition) (begin . body)))))
34 ;;;--------------------------------------------------------------------------
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)
42 (continuation %coroutine-continuation %set-coroutine-continuation!))
44 (define %current-coroutine (make-coroutine #f))
45 (define (current-coroutine)
46 ;; Return the current coroutine.
49 (define %calling-coroutine #f)
50 (define (calling-coroutine)
51 ;; Return the coroutine that invoked the current one. Before any switch,
55 (define (resume coroutine . args)
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.
61 (call-with-current-continuation
63 (%set-coroutine-continuation! %current-coroutine k)
64 (set! %calling-coroutine %current-coroutine)
65 (set! %current-coroutine coroutine)
66 (apply (%coroutine-continuation coroutine) args))))
68 ;;;--------------------------------------------------------------------------
71 (define-syntax define-generator
72 ;; Define a function returning a generator. The generator yields whatever
73 ;; the function body does.
76 ((define-generator (name . args) . body)
78 (make-coroutine (lambda ()
80 (resume (calling-coroutine) #f #f)))))))
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
87 (with-values () (resume (calling-coroutine) object #t) #f))
89 (define (list-generator gen)
90 ;; Collect the elements generated by GEN into a list and return it.
93 (with-values (it any?) (resume gen)
98 (define (same-generators? gen-a gen-b)
99 ;; Return whether GEN-A and GEN-B generate the same elements in the same
103 (with-values (a any-a?) (resume gen-a)
104 (with-values (b any-b?) (resume gen-b)
105 (cond ((not any-a?) (not any-b?))
110 ;;;--------------------------------------------------------------------------
113 ;; Assumes SRFI-9; widely available.
114 (define-record-type node
115 ;; A node in a simple binary tree. Empty subtrees are denoted by ().
117 (make-node left data right)
123 (define-generator (fringe node)
124 ;; Generate the elements of the tree headed by NODE inorder.
126 (let recur ((node node))
128 (recur (node-left node))
129 (yield (node-data node))
130 (recur (node-right node)))))
132 (define (parse-tree string)
133 ;; Return a tree constructed according to STRING.
137 ;; tree ::= empty | `(' tree char tree `)'
139 ;; disambiguated by treating `(' as starting a tree wherever a tree is
142 (let ((len (string-length string)))
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) #\)))
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"))
158 ;;;--------------------------------------------------------------------------
162 (cond ((null? args) (error "bad args"))
164 (do ((l (list-generator (fringe (parse-tree (car args)))) (cdr l)))
166 (write-char (car l)))
169 (display (if (same-generators? (fringe (parse-tree (car args)))
170 (fringe (parse-tree (cadr args))))
174 (else (error "bad args"))))
176 ;; Chicken-specific (works in interpreter and standalone compiled code).
177 (let ((program (car (argv))))
178 (condition-case (begin (main (command-line-arguments)) (exit))
180 (print-error-message err (current-error-port) program)
183 ;;;----- That's all, folks --------------------------------------------------