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 ;;;--------------------------------------------------------------------------
   7 ;;; Utilities.
   8
   9 (define-syntax with-values
  10   ;; Bind the values returned by FORM to the VARS and evaluate BODY.
  11
  12   (syntax-rules ()
  13     ((with-values vars form . body)
  14      (call-with-values (lambda () form)
  15        (lambda stuff
  16          (apply (lambda vars . body) stuff))))))
  17
  18 (define-syntax when
  19   ;; If CONDITION is not #f then evaluate BODY.
  20
  21   (syntax-rules ()
  22     ((when condition . body)
  23      (if condition (begin . body)))))
  24
  25 (define-syntax unless
  26   ;; If CONDITION is #f then evaluate BODY.
  27
  28   (syntax-rules ()
  29     ((unless condition . body)
  30      (if (not condition) (begin . body)))))
  31
  32 ;;;--------------------------------------------------------------------------
  33 ;;; Coroutines.
  34
  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)
  39   coroutine?
  40   (continuation %coroutine-continuation %set-coroutine-continuation!))
  41
  42 (define %current-coroutine (make-coroutine #f))
  43 (define (current-coroutine)
  44   ;; Return the current coroutine.
  45   %current-coroutine)
  46
  47 (define %calling-coroutine #f)
  48 (define (calling-coroutine)
  49   ;; Return the coroutine that invoked the current one.  Before any switch,
  50   ;; this is #f.
  51   %calling-coroutine)
  52
  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.
  58
  59   (call-with-current-continuation
  60    (lambda (k)
  61      (%set-coroutine-continuation! %current-coroutine k)
  62      (set! %calling-coroutine %current-coroutine)
  63      (set! %current-coroutine coroutine)
  64      (apply (%coroutine-continuation coroutine) args))))
  65
  66 ;;;--------------------------------------------------------------------------
  67 ;;; Generators.
  68
  69 (define-syntax define-generator
  70   ;; Define a function returning a generator.  The generator yields whatever
  71   ;; the function body does.
  72
  73   (syntax-rules ()
  74     ((define-generator (name . args) . body)
  75      (define (name . args)
  76        (make-coroutine (lambda ()
  77                          (begin . body)
  78                          (resume (calling-coroutine) #f #f)))))))
  79
  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
  83   ;; of the sequence.
  84
  85   (with-values () (resume (calling-coroutine) object #t) #f))
  86
  87 (define (reduce-generator func init gen)
  88   ;; Call FUNC for each item in the generator GEN.
  89   ;;
  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.
  93
  94   (let loop ((state init))
  95     (with-values (item any?) (resume gen)
  96       (if any?
  97           (loop (func item state))
  98           state))))
  99
 100 (define (list-generator gen)
 101   ;; Collect the elements generated by GEN into a list and return it.
 102
 103   (reverse (reduce-generator cons '() gen)))
 104
 105 (define (same-generators? gen-a gen-b)
 106   ;; Return whether GEN-A and GEN-B generate the same elements in the same
 107   ;; order.
 108
 109   (let loop ()
 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?))
 113               ((not any-b?) #f)
 114               ((eqv? a b) (loop))
 115               (else #f))))))
 116
 117 ;;;--------------------------------------------------------------------------
 118 ;;; Nodes and trees.
 119
 120 ;; Assumes SRFI-9; widely available.
 121 (define-record-type node
 122   ;; A node in a simple binary tree.  Empty subtrees are denoted by ().
 123
 124   (make-node left data right)
 125   node?
 126   (left node-left)
 127   (data node-data)
 128   (right node-right))
 129
 130 (define-generator (fringe node)
 131   ;; Generate the elements of the tree headed by NODE inorder.
 132
 133   (let recur ((node node))
 134     (unless (null? node)
 135       (recur (node-left node))
 136       (yield (node-data node))
 137       (recur (node-right node)))))
 138
 139 (define (parse-tree string)
 140   ;; Return a tree constructed according to STRING.
 141   ;;
 142   ;; Syntax is:
 143   ;;
 144   ;;    tree ::= empty | `(' tree char tree `)'
 145   ;;
 146   ;; disambiguated by treating `(' as starting a tree wherever a tree is
 147   ;; expected.
 148
 149   (let ((len (string-length string)))
 150     (define (parse i)
 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) #\)))
 158                      (error "missing )"))
 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"))
 163       tree)))
 164
 165 ;;;--------------------------------------------------------------------------
 166 ;;; Main program.
 167
 168 (define (main args)
 169   (cond ((null? args) (error "bad args"))
 170         ((null? (cdr args))
 171          (reduce-generator (lambda (ch ?) (write-char ch)) #f
 172                            (fringe (parse-tree (car args))))
 173          (newline))
 174         ((null? (cddr args))
 175          (display (if (same-generators? (fringe (parse-tree (car args)))
 176                                         (fringe (parse-tree (cadr args))))
 177                       "match"
 178                       "no match"))
 179          (newline))
 180         (else (error "bad args"))))
 181
 182 ;; Chicken-specific (works in interpreter and standalone compiled code).
 183 (let ((program (car (argv))))
 184   (condition-case (begin (main (command-line-arguments)) (exit))
 185     (err (exn)
 186       (print-error-message err (current-error-port) program)
 187       (exit 1))))
 188
 189 ;;;----- That's all, folks --------------------------------------------------