| 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 | |
| 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. |
| 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) |
| 80 | (resume (calling-coroutine) #f #f))))))) |
| 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 | |
| 87 | (with-values () (resume (calling-coroutine) object #t) #f)) |
| 88 | |
| 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 | |
| 102 | (define (list-generator gen) |
| 103 | ;; Collect the elements generated by GEN into a list and return it. |
| 104 | |
| 105 | (reverse (reduce-generator cons '() gen))) |
| 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 () |
| 112 | (with-values (a any-a?) (resume gen-a) |
| 113 | (with-values (b any-b?) (resume gen-b) |
| 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)) |
| 173 | (reduce-generator (lambda (ch ?) (write-char ch)) #f |
| 174 | (fringe (parse-tree (car args)))) |
| 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 -------------------------------------------------- |