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 (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 --------------------------------------------------