cl: Dump a core image to improve startup times.

[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 (switch-cr 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)
                         (switch-cr (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 () (switch-cr (calling-coroutine) object #t) #f))

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

  (let loop ((l '()))
    (with-values (it any?) (switch-cr gen)
      (if any?
          (loop (cons it l))
          (reverse l)))))

(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?) (switch-cr gen-a)
      (with-values (b any-b?) (switch-cr 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))
         (do ((l (list-generator (fringe (parse-tree (car args)))) (cdr l)))
             ((null? l))
           (write-char (car l)))
         (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 --------------------------------------------------