chiark - git - mdw - fringe/blob - scheme-fringe.scm

   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 (list-generator gen)
  90   ;; Collect the elements generated by GEN into a list and return it.
  91
  92   (let loop ((l '()))
  93     (with-values (it any?) (resume gen)
  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 ()
 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?))
 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 --------------------------------------------------