go: New language.

[fringe] / scheme-fringe.scm

;;; -*-scheme-*-
;;;
;;; Scheme implementation of a `same-fringe' solver.  Assumes Chicken, but
;;; should port easily.

(use syntax-case)			; Chicken-specfic

;;;--------------------------------------------------------------------------
;;; Utilities.

(define-syntax with-values
  ;; Bind the values returned by FORM to the VARS and evaluate BODY.

  (syntax-rules ()
    ((with-values vars form . body)
     (call-with-values (lambda () form)
       (lambda stuff
	 (apply (lambda vars . body) stuff))))))

(define-syntax when
  ;; If CONDITION is not #f then evaluate BODY.

  (syntax-rules ()
    ((when condition . body)
     (if condition (begin . body)))))

(define-syntax unless
  ;; If CONDITION is #f then evaluate BODY.

  (syntax-rules ()
    ((unless condition . body)
     (if (not condition) (begin . body)))))

;;;--------------------------------------------------------------------------
;;; Coroutines.

(define-record-type coroutine
  ;; A coroutine simply remembers the continuaton which was suspended when it
  ;; last invoked a different coroutine.
  (make-coroutine continuation)
  coroutine?
  (continuation %coroutine-continuation %set-coroutine-continuation!))

(define %current-coroutine (make-coroutine #f))
(define (current-coroutine)
  ;; Return the current coroutine.
  %current-coroutine)

(define %calling-coroutine #f)
(define (calling-coroutine)
  ;; Return the coroutine that invoked the current one.  Before any switch,
  ;; this is #f.
  %calling-coroutine)

(define (resume coroutine . args)
  ;; Switch to COROUTINE, passing it ARGS.  When this coroutine is resumed
  ;; (by calling `switch', naturally) it will return the values passed as
  ;; arguments.  A new coroutine (made by `make-coroutine') receives these
  ;; values as its arguments.

  (call-with-current-continuation
   (lambda (k)
     (%set-coroutine-continuation! %current-coroutine k)
     (set! %calling-coroutine %current-coroutine)
     (set! %current-coroutine coroutine)
     (apply (%coroutine-continuation coroutine) args))))

;;;--------------------------------------------------------------------------
;;; Generators.

(define-syntax define-generator
  ;; Define a function returning a generator.  The generator yields whatever
  ;; the function body does.

  (syntax-rules ()
    ((define-generator (name . args) . body)
     (define (name . args)
       (make-coroutine (lambda ()
                         (begin . body)
                         (resume (calling-coroutine) #f #f)))))))

(define (yield object)
  ;; Yield OBJECT from a generator.  The generator protocol returns two
  ;; values each time: either an object and #t, or #f twice to mark the end
  ;; of the sequence.

  (with-values () (resume (calling-coroutine) object #t) #f))

(define (reduce-generator func init gen)
  ;; Call FUNC for each item in the generator GEN.
  ;;
  ;; We maintain a STATE, which is initially INIT.  For each ITEM produced by
  ;; the generator, we replace the state by (FUNC ITEM STATE); finally, we
  ;; return the final state.

  (let loop ((state init))
    (with-values (item any?) (resume gen)
      (if any?
	  (loop (func item state))
	  state))))

(define (list-generator gen)
  ;; Collect the elements generated by GEN into a list and return it.

  (reverse (reduce-generator cons '() gen)))

(define (same-generators? gen-a gen-b)
  ;; Return whether GEN-A and GEN-B generate the same elements in the same
  ;; order.

  (let loop ()
    (with-values (a any-a?) (resume gen-a)
      (with-values (b any-b?) (resume gen-b)
	(cond ((not any-a?) (not any-b?))
	      ((not any-b?) #f)
	      ((eqv? a b) (loop))
	      (else #f))))))

;;;--------------------------------------------------------------------------
;;; Nodes and trees.

;; Assumes SRFI-9; widely available.
(define-record-type node
  ;; A node in a simple binary tree.  Empty subtrees are denoted by ().

  (make-node left data right)
  node?
  (left node-left)
  (data node-data)
  (right node-right))

(define-generator (fringe node)
  ;; Generate the elements of the tree headed by NODE inorder.

  (let recur ((node node))
    (unless (null? node)
      (recur (node-left node))
      (yield (node-data node))
      (recur (node-right node)))))

(define (parse-tree string)
  ;; Return a tree constructed according to STRING.
  ;;
  ;; Syntax is:
  ;;
  ;;	tree ::= empty | `(' tree char tree `)'
  ;;
  ;; disambiguated by treating `(' as starting a tree wherever a tree is
  ;; expected.

  (let ((len (string-length string)))
    (define (parse i)
      (cond ((>= i len) (values '() i))
	    ((char=? (string-ref string i) #\()
	     (with-values (left i) (parse (+ 1 i))
	       (unless (< i len) (error "no data"))
	       (let ((data (string-ref string i)))
		 (with-values (right i) (parse (+ 1 i))
		   (unless (and (< i len) (char=? (string-ref string i) #\)))
		     (error "missing )"))
		   (values (make-node left data right) (+ 1 i))))))
	    (else (values '() i))))
    (with-values (tree i) (parse 0)
      (unless (= i len) (error "trailing junk"))
      tree)))

;;;--------------------------------------------------------------------------
;;; Main program.

(define (main args)
  (cond ((null? args) (error "bad args"))
	((null? (cdr args))
	 (reduce-generator (lambda (ch ?) (write-char ch)) #f
			   (fringe (parse-tree (car args))))
	 (newline))
	((null? (cddr args))
	 (display (if (same-generators? (fringe (parse-tree (car args)))
					(fringe (parse-tree (cadr args))))
		      "match"
		      "no match"))
	 (newline))
	(else (error "bad args"))))

;; Chicken-specific (works in interpreter and standalone compiled code).
(let ((program (car (argv))))
  (condition-case (begin (main (command-line-arguments)) (exit))
    (err (exn)
      (print-error-message err (current-error-port) program)
      (exit 1))))

;;;----- That's all, folks --------------------------------------------------