;;; Scheme implementation of a `same-fringe' solver. Assumes Chicken, but
;;; should port easily.
-(use syntax-case) ; Chicken-specfic
-
;;;--------------------------------------------------------------------------
;;; Utilities.
;; this is #f.
%calling-coroutine)
-(define (switch-cr coroutine . args)
+(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
((define-generator (name . args) . body)
(define (name . args)
(make-coroutine (lambda ()
- (begin . body)
- (switch-cr (calling-coroutine) #f #f)))))))
+ (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 () (switch-cr (calling-coroutine) object #t) #f))
+ (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.
- (let loop ((l '()))
- (with-values (it any?) (switch-cr gen)
- (if any?
- (loop (cons it l))
- (reverse l)))))
+ (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?) (switch-cr gen-a)
- (with-values (b any-b?) (switch-cr gen-b)
+ (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))
(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)))
+ (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)))