;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)

;;> A lot of miscellaneous functionality that is needed for Swindle, or
;;> useful by itself.

(module misc (lib "base.ss" "swindle")

(require (lib "list.ss"))
(provide (all-from (lib "list.ss")))
(require (lib "etc.ss"))
(provide (all-from (lib "etc.ss")))
(require (all-except (lib "string.ss") regexp-quote))
(provide (all-from (lib "string.ss")))

;; ----------------------------------------------------------------------------
;;>>... Convenient syntax definitions

;;>> (define* ...)
;;>   Just like `define', except that the defined identifier is
;;>   automatically `provide'd.  Doesn't work for defining values.
(provide define*)
(define-syntax (define* stx)
  (syntax-case stx ()
    [(_ x . xs)
     (let ([name (let loop ([x #'x])
                   (syntax-case x () [(x . xs) (loop #'x)] [_ x]))])
       #`(begin (provide #,name) (define x . xs)))]))
;;>> (make-provide-syntax orig-def-syntax provide-def-syntax)
;;>   Creates `provide-def-syntax' as a syntax that is the same as
;;>   `orig-def-syntax' together with an automatic `provide' form for the
;;>   defined symbol, which should be either the first argument or the first
;;>   identifier in a list (it does not work for recursive nesting).  The
;;>   convention when this is used is to use a "*" suffix for the second
;;>   identifier.
(provide make-provide-syntax)
(define-syntax make-provide-syntax
  (syntax-rules ()
    [(_ form form*)
     (define-syntax form*
       (syntax-rules ()
         [(_ (id . as) . r) (begin (provide id) (form (id . as) . r))]
         [(_ id . r) (begin (provide id) (form id . r))]))]))
;;>> (define-syntax* ...)
;;>   Defined as the auto-provide form of `define-syntax'.
(provide define-syntax*)
(make-provide-syntax define-syntax define-syntax*)

;;>> (defsyntax ...)
;;>> (defsyntax* ...)
;;>> (letsyntax (local-syntaxes ...) ...)
;;>   These are just shorthands for `define-syntax', `define-syntax*', and
;;>   `let-syntax'.  This naming scheme is consistent with other definitions
;;>   in this module (and the rest of Swindle).
(define-syntax* defsyntax
  (syntax-rules () [(_ . args) (define-syntax . args)]))
(make-provide-syntax defsyntax defsyntax*) (provide defsyntax*)
(define-syntax* letsyntax
  (syntax-rules () [(_ . args) (let-syntax . args)]))

;;>> (defsubst name body)
;;>> (defsubst* name body)
;;>> (letsubst ([name body] ...) letbody ...)
;;>   These are convenient ways of defining simple pattern transformer
;;>   syntaxes (simple meaning they're much like inlined functions).  In
;;>   each of these forms, the `name' can be either a `(name arg ...)' which
;;>   will define a simple macro or an identifier which will define a
;;>   symbol-macro.  For example:
;;>     => (defsubst (my-if cond then else)
;;>          (if (and cond (not (eq? 0 cond))) then else))
;;>     => (my-if 1 (echo 2) (echo 3))
;;>     2
;;>     => (my-if 0 (echo 2) (echo 3))
;;>     3
;;>     => (define x (list 1 2 3))
;;>     => (defsubst car-x (car x))
;;>     => car-x
;;>     1
;;>     => (set! car-x 11)
;;>     => x
;;>     (11 2 3)
;;>   Actually, if a `(name arg ...)' is used, then the body can have more
;;>   pattern/expansions following -- but since this form translates to a
;;>   usage of `syntax-rules', the `name' identifier should normally be `_'
;;>   in subsequent patterns.  For example:
;;>     => (defsubst (my-if cond then else)
;;>                    (if (and cond (not (eq? 0 cond))) then else)
;;>                  (_ cond then)
;;>                    (and cond (not (eq? 0 cond)) then))
;;>     => (my-if 0 1)
;;>     #f
;;>   Finally, note that since these are just patterns that get handled by
;;>   syntax-rules, all the usual pattern stuff applies, like using `...'.

(defsyntax defsubst-process
  (syntax-rules ()
    [(_ name (acc ...)) (define-syntax name (syntax-rules () acc ...))]
    [(_ name (acc ...) n+a subst . more)
     (defsubst-process name (acc ... (n+a subst)) . more)]))
(defsyntax* defsubst
  (syntax-rules ()
    [(_ (name . args) subst)
     (define-syntax name
       (syntax-rules () [(name . args) subst]))]
    [(_ (name . args) subst . more)
     (defsubst-process name () (name . args) subst . more)]
    [(_ name subst)
     (define-syntax (name stx)
       (syntax-case stx () ; syntax-rules won't handle identifier expansion
         ;; doesn't matter here, but see `letsubst' for an explanation on `___'
         [(___ . args) (syntax/loc stx (subst . args))]
         [___          (syntax/loc stx subst)]))]))
(make-provide-syntax defsubst defsubst*) (provide defsubst*)

;; a let version of the above
(defsyntax* (letsubst stx)
  (syntax-case stx ()
    [(_ ([name body] ...) letbody ...)
     (quasisyntax/loc stx
       (let-syntax
           #,(map
              (lambda (name body)
                ;; use `___' in the following, if we use `name', then it would
                ;; not be possible to make an X subst that expand to something
                ;; with the previous X, so (let ([x 1]) (letsubst ([x x]) x))
                ;; will loop forever instead of returning 1.
                (syntax-case name ()
                  [(name . args)
                   (quasisyntax/loc body
                     (name (syntax-rules () [(___ . args) #,body])))]
                  [name (identifier? #'name)
                   (quasisyntax/loc body
                     (name
                      (lambda (stx)
                        (syntax-case stx ()
                          [(___ . args) (syntax/loc stx (#,body . args))]
                          [___          (syntax/loc stx #,body)]))))]))
              (syntax-e #'(name ...)) (syntax-e #'(body ...)))
         letbody ...))]))

;;>> (defmacro name body)
;;>> (defmacro* name body)
;;>> (letmacro ([name body] ...) letbody ...)
;;>   These are just like MzScheme's define-macro (from mzlib/defmacro) with
;;>   two major extensions:
;;>   * If `name' is a simple identifier then a symbol-macro is defined (as
;;>     with `defsubst' above).
;;>   * A `letmacro' form for local macros is provided.

(require-for-syntax (lib "dmhelp.ss" "mzlib" "private"))
(provide defmacro letmacro)
(define-syntaxes (defmacro letmacro)
  (let ()
    (define (syntax-null? x)
      (or (null? x) (and (syntax? x) (null? (syntax-e x)))))
    (define (syntax-pair? x)
      (or (pair? x) (and (syntax? x) (pair? (syntax-e x)))))
    (define (syntax-car x)   (if (pair? x) (car x) (car (syntax-e x))))
    (define (syntax-cdr x)   (if (pair? x) (cdr x) (cdr (syntax-e x))))
    (define (check-args stx name args)
      (unless (identifier? name)
        (raise-syntax-error
         #f "expected an identifier for the macro name" stx name))
      (let loop ([args args])
        (cond [(syntax-null? args) 'ok]
              [(identifier? args) 'ok]
              [(syntax-pair? args)
               (unless (identifier? (syntax-car args))
                 (raise-syntax-error
                  #f "expected an identifier for a macro argument"
                  stx (syntax-car args)))
               (loop (syntax-cdr args))]
              [else
               (raise-syntax-error
                #f "not a valid argument sequence after the macro name"
                stx)])))
    (values
     (lambda (stx) ; defmacro
       (syntax-case stx ()
         [(_ (name . args) body0 body ...)
          (begin
            (check-args stx #'name #'args)
            #'(define-syntax name
                (let ([p (lambda args body0 body ...)])
                  (lambda (stx)
                    (let ([l (syntax->list stx)])
                      (unless (and l (procedure-arity-includes?
                                      p (sub1 (length l))))
                        (raise-syntax-error #f "bad form" stx))
                      (let ([ht (make-hash-table)])
                        (datum->syntax-object
                         stx
                         (dm-subst
                          ht (apply p (cdr (dm-syntax->datum stx ht))))
                         stx)))))))]
         [(_ name body) (identifier? #'name)
          #'(define-syntax name
              (lambda (stx)
                (syntax-case stx ()
                  [(_ . xs) (quasisyntax/loc stx
                              (#,(datum->syntax-object stx body stx) . xs))]
                  [_ (datum->syntax-object stx body stx)])))]))
     (lambda (stx) ; letmacro
       (syntax-case stx ()
         [(_ ([name body] ...) letbody ...)
          (quasisyntax/loc stx
            (let-syntax
                #,(map
                   (lambda (name body)
                     (if (identifier? name)
                       (quasisyntax/loc body
                         (#,name
                          (lambda (stx)
                            (syntax-case stx ()
                              [(_1 . xs)
                               (quasisyntax/loc stx
                                 (#,(datum->syntax-object stx body stx)
                                  . xs))]
                              [_1 (datum->syntax-object stx #,body stx)]))))
                       (syntax-case name ()
                         [(name . args)
                          (begin
                            (check-args stx #'name #'args)
                            (quasisyntax/loc body
                              (name
                               (let ([p (lambda args #,body)])
                                 (lambda (stx)
                                   (let ([l (syntax->list stx)])
                                     (unless
                                         (and l (procedure-arity-includes?
                                                 p (sub1 (length l))))
                                       (raise-syntax-error #f "bad form" stx))
                                     (let ([ht (make-hash-table)])
                                       (datum->syntax-object
                                        stx
                                        (dm-subst
                                         ht (apply p (cdr (dm-syntax->datum
                                                           stx ht))))
                                        stx))))))))])))
                   (syntax-e #'(name ...)) (syntax-e #'(body ...)))
              letbody ...))])))))
(make-provide-syntax defmacro defmacro*) (provide defmacro*)

;; ----------------------------------------------------------------------------
;;>>... Controlling syntax

;;>> (define-syntax-parameter name default)
;;>> (define-syntax-parameter* name default)
;;>   Creates a `syntax parameter'.  Syntax parameters are things that you
;;>   can use just like normal parameters, but they are syntax transformers,
;;>   and the information they store can be used by other syntax
;;>   transformers.  The purpose of having them around is to parameterize
;;>   the way syntax transformation is used -- so they should be used as
;;>   global option changes, not for frequent side effect: they change their
;;>   value at syntax expansion time.  Note that using it stores the literal
;;>   syntax that is passed to them -- there is no way to evaluate the given
;;>   argument, for example, if some parameter expects a boolean -- then
;;>   `(not #t)' will not work!  The syntax parameter itself is invoked
;;>   wither with no arguments to retrieve its value, or with an argument to
;;>   set it.  Retrieving or setting the value in this way is meaningful
;;>   only in an interactive context since using it in a function just
;;>   expands to the current value:
;;>     => (define-syntax-parameter -foo- 1)
;;>     => (-foo-)
;;>     1
;;>     => (define (foo) (-foo-))
;;>     => (-foo- 2)
;;>     => (-foo-)
;;>     2
;;>     => (foo)
;;>     1
(defsyntax* define-syntax-parameter
  (syntax-rules ()
    [(_ name default)
     (define-syntax name
       (let ([p (make-parameter #'default)])
         (lambda stx
           (if (null? stx)
             (p) ; when the value is used in other transformers
             (syntax-case (car stx) ()
               [(_ new) (begin (p #'new) #'(void))]
               [(_)     (p)])))))]))
(make-provide-syntax define-syntax-parameter define-syntax-parameter*)
(provide define-syntax-parameter*)

;; ----------------------------------------------------------------------------
;;>>... Setters and more list accessors

;;>> (set-caar! place x)
;;>> (set-cadr! place x)
;;>> (set-cdar! place x)
;;>> (set-cddr! place x)
;;>> (set-caaar! place x)
;;>> (set-caadr! place x)
;;>> (set-cadar! place x)
;;>> (set-caddr! place x)
;;>> (set-cdaar! place x)
;;>> (set-cdadr! place x)
;;>> (set-cddar! place x)
;;>> (set-cdddr! place x)
;;>> (set-caaaar! place x)
;;>> (set-caaadr! place x)
;;>> (set-caadar! place x)
;;>> (set-caaddr! place x)
;;>> (set-cadaar! place x)
;;>> (set-cadadr! place x)
;;>> (set-caddar! place x)
;;>> (set-cadddr! place x)
;;>> (set-cdaaar! place x)
;;>> (set-cdaadr! place x)
;;>> (set-cdadar! place x)
;;>> (set-cdaddr! place x)
;;>> (set-cddaar! place x)
;;>> (set-cddadr! place x)
;;>> (set-cdddar! place x)
;;>> (set-cddddr! place x)
;;>   These are all defined so it is possible to use `setf!' from "setf.ss"
;;>   with these standard and library-provided functions.
(define* set-caar!   (lambda (p v) (set-car! (car p) v)))
(define* set-cadr!   (lambda (p v) (set-car! (cdr p) v)))
(define* set-cdar!   (lambda (p v) (set-cdr! (car p) v)))
(define* set-cddr!   (lambda (p v) (set-cdr! (cdr p) v)))
(define* set-caaar!  (lambda (p v) (set-car! (caar p) v)))
(define* set-caadr!  (lambda (p v) (set-car! (cadr p) v)))
(define* set-cadar!  (lambda (p v) (set-car! (cdar p) v)))
(define* set-caddr!  (lambda (p v) (set-car! (cddr p) v)))
(define* set-cdaar!  (lambda (p v) (set-cdr! (caar p) v)))
(define* set-cdadr!  (lambda (p v) (set-cdr! (cadr p) v)))
(define* set-cddar!  (lambda (p v) (set-cdr! (cdar p) v)))
(define* set-cdddr!  (lambda (p v) (set-cdr! (cddr p) v)))
(define* set-caaaar! (lambda (p v) (set-car! (caaar p) v)))
(define* set-caaadr! (lambda (p v) (set-car! (caadr p) v)))
(define* set-caadar! (lambda (p v) (set-car! (cadar p) v)))
(define* set-caaddr! (lambda (p v) (set-car! (caddr p) v)))
(define* set-cadaar! (lambda (p v) (set-car! (cdaar p) v)))
(define* set-cadadr! (lambda (p v) (set-car! (cdadr p) v)))
(define* set-caddar! (lambda (p v) (set-car! (cddar p) v)))
(define* set-cadddr! (lambda (p v) (set-car! (cdddr p) v)))
(define* set-cdaaar! (lambda (p v) (set-cdr! (caaar p) v)))
(define* set-cdaadr! (lambda (p v) (set-cdr! (caadr p) v)))
(define* set-cdadar! (lambda (p v) (set-cdr! (cadar p) v)))
(define* set-cdaddr! (lambda (p v) (set-cdr! (caddr p) v)))
(define* set-cddaar! (lambda (p v) (set-cdr! (cdaar p) v)))
(define* set-cddadr! (lambda (p v) (set-cdr! (cdadr p) v)))
(define* set-cdddar! (lambda (p v) (set-cdr! (cddar p) v)))
(define* set-cddddr! (lambda (p v) (set-cdr! (cdddr p) v)))

;;>> (1st list)
;;>> (2nd list)
;;>> (3rd list)
;;>> (4th list)
;;>> (5th list)
;;>> (6th list)
;;>> (7th list)
;;>> (8th list)
;;>   Quick list accessors -- no checking is done, which makes these
;;>   slightly faster than the bindings provided by mzlib/list.
(define* 1st car)
(define* 2nd cadr)
(define* 3rd caddr)
(define* 4th cadddr)
(define* 5th (lambda (x) (car (cddddr x))))
(define* 6th (lambda (x) (cadr (cddddr x))))
(define* 7th (lambda (x) (caddr (cddddr x))))
(define* 8th (lambda (x) (cadddr (cddddr x))))

;;>> (set-1st! list x)
;;>> (set-2nd! list x)
;;>> (set-3rd! list x)
;;>> (set-4th! list x)
;;>> (set-5th! list x)
;;>> (set-6th! list x)
;;>> (set-7th! list x)
;;>> (set-8th! list x)
;;>   Setter functions for the above.
(define* set-1st! set-car!)
(define* set-2nd! set-cadr!)
(define* set-3rd! set-caddr!)
(define* set-4th! set-cadddr!)
(define* set-5th! (lambda (p v) (set-car! (cddddr p) v)))
(define* set-6th! (lambda (p v) (set-car! (cdr (cddddr p)) v)))
(define* set-7th! (lambda (p v) (set-car! (cddr (cddddr p)) v)))
(define* set-8th! (lambda (p v) (set-car! (cdddr (cddddr p)) v)))

;;>> (head pair)
;;>> (tail pair)
;;>> (set-head! pair x)
;;>> (set-tail! pair x)
;;>   Synonyms for `first', `rest', `set-first!', `set-rest!'.
(define* head first)
(define* tail rest)
(define* set-head! set-first!)
(define* set-tail! set-rest!)

;;>> (set-second! list x)
;;>> (set-third! list x)
;;>> (set-fourth! list x)
;;>> (set-fifth! list x)
;;>> (set-sixth! list x)
;;>> (set-seventh! list x)
;;>> (set-eighth! list x)
;;>   Defined to allow `setf!' with these mzlib/list functions.  Note that
;;>   there is no error checking (unlike the accessor functions which are
;;>   provided by mzlib/list).
(define* set-second!  set-2nd!)
(define* set-third!   set-3rd!)
(define* set-fourth!  set-4th!)
(define* set-fifth!   set-5th!)
(define* set-sixth!   set-6th!)
(define* set-seventh! set-7th!)
(define* set-eighth!  set-8th!)

;;>> (nth list n)
;;>> (nthcdr list n)
;;>   Functions for pulling out the nth element and the nth tail of a list.
;;>   Note the argument order which is unlike the one in CL.
(define* nth list-ref)
(define* (nthcdr l n)
  (if (zero? n) l (nthcdr (cdr l) (- n 1))))

;;>> (list-set! list n x)
;;>> (set-nth! list n x)
;;>   A function to set the nth element of a list, also provided as
;;>   `set-nth!' to allow using `setf!' with `nth'.
(define* (list-set! lst index new)
  (set-car! (nthcdr lst index) new))
(define* set-nth! list-set!)

;;>> (set-list-ref! list n x)
;;>> (set-vector-ref! vector n x)
;;>> (set-string-ref! string n x)
;;>   These are defined as `list-set!', `vector-set!', and `string-set!', so
;;>   the accessors can be used with `setf!'.
(define* set-list-ref!   list-set!)
(define* set-vector-ref! vector-set!)
(define* set-string-ref! string-set!)

;;>> (last list)
;;>> (set-last! list x)
;;>   Accessing a list's last element, and modifying it.
(define* (last l)
  (car (last-pair l)))
(define* (set-last! l x)
  (set-car! (last-pair l) x))

;;>> (set-unbox! box x)
;;>   Allow using `setf!' with `unbox'.  Note: this is an alias for
;;>   `set-box!' which is an inconsistent name with other Scheme `set-foo!'
;;>   functions -- the result is that you can also do `(setf! (box foo) x)'
;;>   and bogusly get the same effect.
(define* set-unbox! set-box!)

;;>> (set-hash-table-get! table key [default] value)
;;>   This is defined to be able to `setf!' into a `hash-table-get'
;;>   accessor.  The form that `setf!' assembles always puts the new value
;;>   last, but it is still useful to have a default thunk which results in
;;>   an optional argument in an unusual place (and this argument is ignored
;;>   by this, which is why it is defined as a macro).  For example:
;;>     => (define t (make-hash-table))
;;>     => (inc! (hash-table-get t 'foo))
;;>     hash-table-get: no value found for key: foo
;;>     => (inc! (hash-table-get t 'foo (thunk 0)))
;;>     => (hash-table-get t 'foo)
;;>     1
(defsubst*
  (set-hash-table-get! table key value) (hash-table-put! table key value)
  (_ table key thunk value)             (hash-table-put! table key value))

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

;;>> (eprintf fmt-string args ...)
;;>   Same as `printf' but it uses the current-error-port.
(define* (eprintf . args)
  (apply fprintf (current-error-port) args))

;;>> concat
;;>   A shorter alias for `string-append'.
(define* concat string-append)

;;>> (symbol-append sym ...)
;;>   Self explanatory.
(define* (symbol-append . symbols)
  (string->symbol (apply string-append (map symbol->string symbols))))

;;>> (maptree func tree)
;;>   Applies given function to a tree made of cons cells, and return the
;;>   results tree with the same shape.
(define* (maptree f x)
  (let loop ([x x])
    (cond [(list? x) (map loop x)]
          [(pair? x) (cons (loop (car x)) (loop (cdr x)))]
          [else (f x)])))

;;>> (map! func list ...)
;;>   Same as `map' -- but destructively modifies the first list to hold the
;;>   results of applying the function.  Assumes all lists have the same
;;>   length.
(define* (map! f l . rest)
  (if (null? rest)
    (let loop ([xs l])
      (if (null? xs) l (begin (set-car! xs (f (car xs))) (loop (cdr xs)))))
    (let loop ([xs l] [ls rest])
      (if (null? xs) l (begin (set-car! xs (apply f (car xs) (map car ls)))
                              (loop (cdr xs) (map cdr ls)))))))

;;>> (maptree! func tree)
;;>   Same as `maptree' -- but destructively modifies the list to hold the
;;>   results of applying the function.
(define* (maptree! f x)
  (if (pair? x)
    (begin (let loop ([x x])
             (defsubst (do-part get set)
               (let ([y (get x)])
                 (cond [(pair? y) (loop y)]
                       [(not (null? y)) (set x (f y))])))
             (do-part car set-car!)
             (do-part cdr set-cdr!))
           x)
    (f x))) ; can't be destructive here

;;>> (mappend func list ...)
;;>> (mappend! func list ...)
;;>   Common idiom for doing a `(map func list ...)' and appending the
;;>   results.  `mappend!' uses `append!'.
(define* (mappend f . ls)
  (apply append (apply map f ls)))
(define* (mappend! f . ls)
  (apply append! (apply map f ls)))

;;>> (mapply func list-of-lists)
;;>   Apply the given `func' on every list in `list-of-lists' and return the
;;>   results list.
(define* (mapply f ls)
  (map (lambda (args) (apply f args)) ls))

;;>> (negate predicate?)
;;>   Returns a negated predicate function.
(define* (negate pred?)
  (lambda x (not (pred? . x))))

;;>> (position-of x list)
;;>   Finds `x' in `list' and returns its index.
(define* (position-of x lst)
  (let loop ([i 0] [l lst])
    (cond [(null? l) #f]
          [(eq? x (car l)) i]
          [else (loop (add1 i) (cdr l))])))

;;>> (find-if predicate? list)
;;>   Find and return an element of `list' which satisfies `predicate?', or
;;>   #f if none found.
(define* (find-if pred? l)
  (let loop ([l l])
    (cond [(null? l) #f]
          [(pred? (car l)) (car l)]
          [else (loop (cdr l))])))

;;>> (some predicate? list ...)
;;>> (every predicate? list ...)
;;>   Similar to MzScheme's `ormap' and `andmap', except that when multiple
;;>   lists are given, the check stops as soon as the shortest list ends.

(define* (some pred? l . rest)          ; taken from slib/comlist.scm,
  (cond [(null? rest)                   ; modified to check only up to the
         (let mapf ([l l])              ; length of the shortest list.
           (and (not (null? l))
                (or (pred? (car l)) (mapf (cdr l)))))]
        [else (let mapf ([l l] [rest rest])
                (and (not (or (null? l) (memq '() rest)))
                     (or (apply pred? (car l) (map car rest))
                         (mapf (cdr l) (map cdr rest)))))]))

(define* (every pred? l . rest)         ; taken from slib/comlist.scm
  (cond [(null? rest)                   ; modified to check only up to the
         (let mapf ([l l])              ; length of the shortest list.
           (or (null? l)
               (and (pred? (car l)) (mapf (cdr l)))))]
        [else (let mapf ([l l] [rest rest])
                (or (null? l) (if (memq '() rest) #t #f)
                    (and (apply pred? (car l) (map car rest))
                         (mapf (cdr l) (map cdr rest)))))]))

;;>> (regexp-quote string)
;;>   The same as `regexp-quote' from mzlib/string, but faster.
(define* regexp-quote
  (let ([re (regexp "[][*?+|().\\$^-]")])
    (lambda (s) (regexp-replace* re s "\\\\&"))))

;;>> (with-output-to-string thunk)
;;>   Run `thunk' collecting generated output into a string.
(define* (with-output-to-string thunk)
  (let ([str (open-output-string)])
    (parameterize ([current-output-port str]) (thunk))
    (get-output-string str)))

;;>> (1+ x)
;;>> (1- x)
;;>   Synonyms for `add1' and `sub1'.
(define* 1+ add1)
(define* 1- sub1)

;; ----------------------------------------------------------------------------
;;>>... Multi-dimensional hash-tables
;; Using lists of `eq?' keys, based on MzScheme's hash tables (MzScheme doesn't
;; have custom hashes).  Use weak hash-tables so no space is redundantly
;; wasted.

;;>> (make-l-hash-table)
;;>> (l-hash-table-get table keys [failure-thunk])
;;>> (l-hash-table-put! table keys value)
;;>> (set-l-hash-table-get! table key [default] value)
;;>   These functions are similar to MzScheme's hash-table functions, except
;;>   that they work with a list of keys (compared with `eq?').  If it was
;;>   possible to use a custom equality hash-table, then then would use
;;>   something like
;;>     (lambda (x y) (and (= (length x) (length y)) (andmap eq? x y))).
;;>   The implementation uses a hash-table of hash-tables, all of them weak,
;;>   since it is supposed to be used for memoization.
;;>
;;>   `set-l-hash-table-get!' is defined to work with `setf!'.

;; Internal values, used below.
(define *nothing* (list "*"))
(define (return-nothing) *nothing*)

(defsubst l-hash-vector-length 10)

(define* (make-l-hash-table)
  (make-vector (add1 l-hash-vector-length) *nothing*))

(define* (l-hash-table-get table keys . thunk)
  (let ([len (length keys)])
    (let loop ([obj (vector-ref table (min len l-hash-vector-length))]
               [keys (if (< len l-hash-vector-length) keys (cons len keys))])
      (cond [(eq? obj *nothing*)
             (if (null? thunk)
               (error 'l-hash-table-get "no value found.") ((car thunk)))]
            [(null? keys) obj]
            [(not (hash-table? obj))
             (error 'l-hash-table-get "got to a premature value.")]
            [else (loop (hash-table-get obj (car keys) return-nothing)
                        (cdr keys))]))))

(define* (l-hash-table-put! table keys value)
  (let* ([len (length keys)]
         [obj (vector-ref table (min len l-hash-vector-length))])
    (when (eq? obj *nothing*)
      (set! obj (if (zero? len) value (make-hash-table 'weak)))
      (vector-set! table (min len l-hash-vector-length) obj))
    (unless (zero? len)
      (let loop ([obj obj]
                 [keys (if (< len l-hash-vector-length) keys (cons len keys))])
        (cond [(not (hash-table? obj))
               (error 'l-hash-table-put! "got to a premature value.")]
              [(null? (cdr keys)) (hash-table-put! obj (car keys) value)]
              [else (let ([value (hash-table-get
                                  obj (car keys) return-nothing)])
                      (when (eq? value *nothing*)
                        (set! value (make-hash-table 'weak))
                        (hash-table-put! obj (car keys) value))
                      (loop value (cdr keys)))])))))

(defsubst*
  (set-l-hash-table-get! table key value) (l-hash-table-put! table key value)
  (_ table key thunk value)               (l-hash-table-put! table key value))

;; Simple memoization.

;;>> (memoize func)
;;>   Return a memoized version of `func'.  Note that if `func' is
;;>   recursive, it should be arranged for it to call the memoized version
;;>   rather then call itself directly.
(define* (memoize f)
  (let ([table (make-l-hash-table)])
    (lambda args
      (l-hash-table-get
       table args
       (thunk
         (let ([r (apply f args)]) (l-hash-table-put! table args r) r))))))

;;>> (memoize! func-name)
;;>   Changes the given function binding to a memoized version.
(defsubst* (memoize! f) (set! f (memoize f)))

;; ---------------------------------------------------------------------------
;;>>... Generic iteration and list comprehension
;; Idea originated in a post on c.l.s by Based on Phil Bewig (July 2002), but
;; went light years beyond that.

;;>> (collect [dir] (var base expr) clause ...)
;;>   Sophisticated iteration syntax.  The iteration is specified by the
;;>   given clauses, where `var' serves as an accumulator variable that
;;>   collects a value beginning with `base' and continuing with `expr' --
;;>   similar to a single binding in a `do' form with a variable, an initial
;;>   value and an update expression.  But there are much more iteration
;;>   options than a `do' form: this form supports a generic
;;>   list-comprehension and related constructs.  Forms that use this
;;>   construct are:
;;>

;;>> (loop-for clause ...)
;;>   Use when no value collection is needed, and the default for
;;>   expressions is to do them instead of using them as a filter.
;;>   Implemented as:
;;>     (collect => (acc (void) acc) do clause ...)
(defsubst* (loop-for clause ...)
  (collect => (acc (void) acc) do clause ...))
;;>

;;>> (list-of expr clause ...)
;;>   Implemented as:
;;>     (reverse! (collect (acc '() (cons expr acc)) clause ...))
(defsubst* (list-of expr clause ...)
  (reverse! (collect (acc '() (cons expr acc)) clause ...)))
;;>

;;>> (sum-of expr clause ...)
;;>   Implemented as:
;;>     (collect (acc 0 (+ expr acc)) clause ...)
(defsubst* (sum-of expr clause ...)
  (collect (acc 0 (+ expr acc)) clause ...))
;;>

;;>> (product-of expr clause ...)
;;>   Implemented as:
;;>     (collect (acc 1 (* expr acc)) clause ...)
(defsubst* (product-of expr clause ...)
  (collect (acc 1 (* expr acc)) clause ...))
;;>

;;>> (count-of clause ...)
;;>   Only count matching cases, implemented as:
;;>     (sum-of 1 clause ...)
(defsubst* (count-of clause ...)
  (sum-of 1 clause ...))
;;>

;;>   Each clause is either:
;;>   * (v <- ...):     a binding generator clause;
;;>   * (v <- ... and v <- ...): parallel generator clauses;
;;>   * (v is is-expr): bind `v' to the result of `is-expr';
;;>   * while expr:     a `while' keyword followed by an expression will
;;>                     abort the whole loop if that expression evaluates to
;;>                     #f;
;;>   * until expr:     an `until' keyword followed by an expression will
;;>                     abort the whole loop if that expression evaluates to
;;>                     a non-#f value;
;;>   * when ...:       filter by the following expressions -- if an
;;>                     expression evaluates to #f, stop processing this
;;>                     iteration (default for all macros except for
;;>                     `loop-for');
;;>   * unless ...:     filter by the negation of the following expressions;
;;>   * do ...:         execute the following expressions, used for side
;;>                     effects (default for the `loop-for' macro);
;;>   * expr:           expression is used according to the current mode set
;;>                     by a `when', `unless', or `do', keyword that
;;>                     precedes it.
;;>   The effect of this form is to iterate each generator variable
;;>   according to generating `<-' clauses (see below for these) and
;;>   parallel clauses, and evaluate the `expr' with each combination, which
;;>   composes a result out of iteration-bound values and an accumulated
;;>   result.  Generation is done in a nested fashion, where the rightmost
;;>   generator spin fastest.  Parallel generators (specified with an infix
;;>   `and') make all iterations happen simultaneously, ending as soon as
;;>   the first one ends.  An `is' clause is used for binding arbitrary
;;>   variables, a `do' clause is used to execute code for general
;;>   side-effects, and other clauses are used to filter results before
;;>   continuing down the clause list.  Each clause can use variables bound
;;>   by previous clauses, and the `expr' can use all bound variables as
;;>   well as the given accumulator variable.
;;>
;;>   An optional first token can be used to specify the direction which is
;;>   used to accumulate the result.  It can be one of these two tokens:
;;>   `<=': A "backward" collection, the default (similar to `foldl');
;;>   `=>': A "forward" collection (similar to `foldr').
;;>   The default "backward" direction works by generating an accumulator
;;>   carrying loop, as in this code (this code is for demonstration, not
;;>   what `collect' creates):
;;>     (let loop ([x foo] [acc '()])
;;>       (if (done? x) acc (loop (next x) (cons (value x) acc))))
;;>   which is a common Scheme idiom for such operations.  The problem is
;;>   that this accumulation happens in reverse -- requiring reversing the
;;>   final result (which is done by the `list-of' macro).  A "forward"
;;>   direction does a naive recursive loop:
;;>     (let loop ([x foo])
;;>       (if (done? x) '() (cons (value x) (loop (next x)))))
;;>   collecting values in the correct order, but the problem is that it
;;>   keeps a computation context which makes memory consumption
;;>   inefficient.  The default style is usually preferred, since reversing
;;>   a list is a cheap operation, but it is not possible when infinite
;;>   lists (streams) are used since it is impossible to reverse them.  In
;;>   these cases, the "forward" style should be used, but the `expr' must
;;>   take care not to evaluate the iteration "variable" immediately, using
;;>   `delay' or a similar mechanism (this "variable" is not bound to a
;;>   value but substituted with an expression (a symbol macro)).  For
;;>   example, here's a quick lazy list usage:
;;>     => (defsubst (lcons x y) (delay (cons x y)))
;;>     => (define (lcar s) (car (force s)))
;;>     => (define (lcdr s) (cdr (force s)))
;;>     => (define x (collect (_ '() (lcons x _)) (x <- 0 ..)))
;;>     ; loops indefinitely
;;>     => (define x (collect => (_ '() (lcons x _)) (x <- 0 ..)))
;;>     => (lcar (lcdr (lcdr x)))
;;>     2
;;>   Note that the `loop-for' macro uses a "forward" direction, but this is
;;>   only because it is slightly faster since it doesn't require an extra
;;>   binding.
;;>   [The direction can be changed for a single part by using a "<-!"
;;>   keyword instead of "<-", but this is an experimental feature since I
;;>   don't know if it's actually useful for anything.  Do not try to mix
;;>   this with the `while' and `until' keywords which are implemented
;;>   differently based on the direction.]
;;>

(defsyntax* (collect stx)
  (define (split id stxs)
    (let loop ([stxs '()] [stxss '()]
               [l (if (syntax? stxs) (syntax->list stxs) stxs)])
      (cond [(null? l) (reverse! (cons (reverse! stxs) stxss))]
            [(and (identifier? (car l)) (module-identifier=? id (car l)))
             (loop '() (cons (reverse! stxs) stxss) (cdr l))]
            [else (loop (cons (car l) stxs) stxss (cdr l))])))
  (define (gen-loop generate add-aux! &optional hacked)
    (with-syntax ([generate generate]
                  [(cur step done? value)
                   (generate-temporaries '(cur step done? value))])
      (add-aux! #'((cur step done? value) (apply values generate)))
      (with-syntax ([value #'(if value (value cur) cur)])
        (with-syntax ([value (if hacked
                               #`(let ([r value]) (set! #,hacked r) r)
                               #'value)])
          #'(cur cur (step cur) (and done? (done? cur)) value)))))
  (define (gen var args add-aux! hack-var! &optional seq?)
    (define (hack!) (when (and seq? hack-var!) (hack-var! var)))
    (define (gen1 arg) (if seq? arg (gen-loop arg add-aux!)))
    (with-syntax ([v var])
      (syntax-case args (then until while .. ..<)
;;>   Generator forms are one of the following ("..", "then", "until",
;;>   "while" are literal tokens), see below for what values are generated:
;;>   * (v <- sequence):
;;>     iterate `v' on values from `sequence';
        [(arg)            (gen1 #'(collect-iterator arg))]
;;>   * (v <- 1st [2nd] .. [last]):
;;>     iterate on an enumerated range, including last element of range;
        [(a b ..  z)      (gen1 #'(collect-numerator a b  z        ))]
        [(a b ..   )      (gen1 #'(collect-numerator a b  #f       ))]
        [(a   ..  z)      (gen1 #'(collect-numerator a #f z        ))]
        [(a   ..   )      (gen1 #'(collect-numerator a #f #f       ))]
;;>   * (v <- 1st [2nd] ..< last):
;;>     iterate on an enumerated range, excluding last element of range;
        [(a b ..< z)      (gen1 #'(collect-numerator a b  z  '<    ))]
        [(a   ..< z)      (gen1 #'(collect-numerator a #f z  '<    ))]
;;>   * (v <- 1st [2nd] .. while last):
;;>     iterate on an enumerated range, excluding last element of range;
        [(a b .. while z) (gen1 #'(collect-numerator a b  z  'while))]
        [(a   .. while z) (gen1 #'(collect-numerator a #f z  'while))]
;;>   * (v <- 1st [2nd] .. until last):
;;>     iterate on an enumerated range, excluding last element of range;
        [(a b .. until z) (gen1 #'(collect-numerator a b  z  'until))]
        [(a   .. until z) (gen1 #'(collect-numerator a #f z  'until))]
;;>   * (v <- x then next-e [{while|until} cond-e]):
;;>     start with the `x' expression, continue with the `next-e' expression
;;>     (which can use `v'), do this while/until `cond-e' is true if a
;;>     condition is given;
        [(arg then next) (hack!)
         (if seq? ; making seq? => convert to composable funcs
           #'(list arg (lambda (v) next) #f #f)
           #'(v arg next #f v))]
        [(arg then next while cond) (hack!)
         (if seq?
           #'(list arg (lambda (v) next) (lambda (v) (not cond)) #f)
           #'(v arg next (not cond) v))]
        [(arg then next until cond) (hack!)
         (if seq?
           #'(list arg (lambda (v) next) (lambda (v) cond) #f)
           #'(v arg next cond v))]
;;>   * (v <- x {while|until} cond-e):
;;>     repeat using the `x' expression while/until `cond-e' is true;
        [(arg while cond) (hack!)
         (if seq?
           #'(list #f #f #f (lambda (_) (if cond arg collect-final)))
           #'(v #f #f #f (begin (set! v arg) (if cond v collect-final))))]
        [(arg until cond) (hack!)
         (if seq?
           #'(list #f #f #f (lambda (_) (if cond collect-final arg)))
           #'(v #f #f #f (begin (set! v arg) (if cond collect-final v))))]
;;>   * (v <- func arg ...):
;;>     applies `func' to `arg ...', the result is expected to be some
;;>     "iterator value" which is used to do the iteration -- iteration
;;>     values are created by `collect-iterator' and `collect-numerator',
;;>     see below for their description and return values.
;;>   * (v <- gen1 <- gen2 <- ...):
;;>     generator clauses can have multiple parts specified by more `<-'s,
;;>     all of them will run sequentially;
        [(f x ...)
         (let ([argss (split #'<- args)])
           (if (= 1 (length argss))
             (gen1 #'(f x ...))
             (let ([hacked #f])
               (with-syntax
                   ([(gen ...)
                     (map (lambda (as)
                            (gen var as add-aux!
                                 (lambda (v) (set! hacked v) (hack-var! v))
                                 #t))
                          argss)])
                 (gen-loop #'(sequential-generators gen ...)
                           add-aux! hacked)))))])))
  (define-values (acc base0 expr clauses fwd?)
    (syntax-case stx (<= =>)
      [(_ <= (acc base expr) clause ...)
       (values #'acc #'base #'expr #'(clause ...) #f)]
      [(_ => (acc base expr) clause ...)
       (values #'acc #'base #'expr #'(clause ...) #t)]
      [(_ (acc base expr) clause ...)
       (values #'acc #'base #'expr #'(clause ...) #f)]))
  (define need-break? #f)
  (define loop-body
    (let c-loop ([base base0] [clauses clauses] [mode 'when] [rev? #f])
      (syntax-case clauses (<- <-! is do when unless while until)
        [() (if (if rev? (not fwd?) fwd?)
              #`(letsubst ([#,acc #,base]) #,expr)
              expr)]
        [((var <-! arg ...) rest ...)
         (c-loop base #'((var <- arg ...) rest ...) mode 'rev!)]
        [((var <- arg ...) rest ...)
;;>   * (v1 <- gen1 ... and v2 <- gen2 ...):
;;>     finally, an infix `and' specifies parallel generators, binding
;;>     several variables.
         (let ([rev? (if (eq? 'rev! rev?) #t #f)]
               [gens (split #'and #'(var <- arg ...))]
               [loop-id (car (generate-temporaries '(loop)))]
               [aux '()] [hacked-vars '()])
           (for-each
            (lambda (g)
              (syntax-case g (<-)
                [(var <- arg ...) (identifier? #'var) #f]
                [_ (raise-syntax-error
                    #f "expected a generator clause" stx g)]))
            gens)
           (with-syntax ([((var <- arg ...) ...) gens])
             ;; Hack needed: generator variables are defined later in the loop
             ;; just before their code, after the place where the expression
             ;; appear in setup code.  This is usually not a problem since
             ;; functions are applied the same, but when using expression
             ;; iteration (`then') in a sequential range which is in
             ;; simultaneous iteration where real expressions are turned to
             ;; functions (which are define before variables the might
             ;; reference).  This could be eliminated, restricting expressions
             ;; from referencing variables that are bound in parallel, but this
             ;; is usually the power of using expression (which can be claimed
             ;; redundant).  The hack is doing this:
             ;;  (let ([x #f] ...)
             ;;    ... (let ([x (let ([r value]) (set! x r) r)])))
             ;; The problem is that the extra junk makes it run twice slower,
             ;; so do this only for bindings that has the above scenario
             ;; (parallel of sequential of expression generators).  To test it,
             ;; do this:
             ;;  (list-of (list c x y)
             ;;    (c <- 1 .. 5 and x <- 1 <- 'x then y
             ;;                 and y <- 1 <- 'y then x))
             ;; but this always works:
             ;;  (list-of (list c x y)
             ;;    (c <- 1 .. 5 and x <- 'x then y and y <- 'y then x))
             (with-syntax ([((cur fst next done? value) ...)
                            (map (lambda (v as)
                                   (gen v as
                                        (lambda (a) (set! aux (cons a aux)))
                                        (lambda (v)
                                          (set! hacked-vars
                                                (cons v hacked-vars)))))
                                 (syntax->list #'(var ...))
                                 (syntax->list #'((arg ...) ...)))]
                           [loop loop-id]
                           [(aux ...) (reverse aux)] [acc acc] [base base])
               (with-syntax
                   ([body
                     (let* ([fwd? (if rev? (not fwd?) fwd?)]
                            [return (if fwd? #'base #'acc)]
                            [body (if fwd?
                                    (c-loop #`(#,loop-id next ...)
                                            #'(rest ...) mode rev?)
                                    #`(loop next ...
                                            #,(c-loop #'acc #'(rest ...)
                                                      mode rev?)))])
                       #`(let-values (aux ...)
                           (let loop ([cur fst] ...
                                      #,@(if fwd? #'() #'((acc base))))
                             (if (or done? ...)
                               #,return
                               #,(let vloop ([vars (syntax->list #'(var ...))]
                                             [values (syntax->list
                                                      #'(value ...))])
                                   (if (null? vars)
                                     body
                                     #`(let ([#,(car vars) #,(car values)])
                                         (if (eq? #,(car vars) collect-final)
                                           #,return
                                           #,(vloop (cdr vars)
                                                    (cdr values))))))))))])
                 (if (null? hacked-vars)
                   #'body
                   (with-syntax ([(var ...) (reverse hacked-vars)])
                     #'(let ([var #f] ...) body)))))))]
        [((var is is-expr) rest ...)
         #`(let ([var is-expr]) #,(c-loop base #'(rest ...) mode rev?))]
        [(while cond rest ...)
         #`(if cond
             #,(c-loop base #'(rest ...) mode rev?)
             #,(if (if rev? (not fwd?) fwd?)
                 base0 (begin (set! need-break? #t) #`(break #,base))))]
        [(until cond rest ...)
         #`(if cond
             #,(if (if rev? (not fwd?) fwd?)
                 base0 (begin (set! need-break? #t) #`(break #,base)))
             #,(c-loop base #'(rest ...) mode rev?))]
        [(do     rest ...) (c-loop base #'(rest ...) 'do     rev?)]
        [(when   rest ...) (c-loop base #'(rest ...) 'when   rev?)]
        [(unless rest ...) (c-loop base #'(rest ...) 'unless rev?)]
        [(expr rest ...)
         (with-syntax ([cont (c-loop base #'(rest ...) mode rev?)])
           (case mode
             [(when)   #`(if expr cont #,base)]
             [(unless) #`(if expr #,base cont)]
             [(do)     #`(begin expr cont)]))])))
  (if need-break?
    #`(let/ec break #,loop-body) loop-body))
;;>

(define (sequential-generators gen . rest)
  (let-values ([(new) #f] [(fst step done? value) (values . gen)])
    (define (next!)
      (and (pair? rest)
           (begin (set! gen   (car rest)) (set! rest  (cdr rest))
                  (set! fst   (1st gen))  (set! step  (2nd gen))
                  (set! done? (3rd gen))  (set! value (4th gen))
                  #t)))
    (list fst
          (lambda (x)
            (let ([r (step (if new (begin0 new (set! new #f)) x))])
              (if (and done? (done? r)) (if (next!) fst collect-final) r)))
          (lambda (x)
            (and (null? rest)
                 (or (eq? x collect-final) (and done? (done? x)))))
          (lambda (x)
            (let ([r (if value (value x) x)])
              (if (eq? r collect-final)
                (let* ([n? (next!)] [r (and n? (if value (value fst) fst))])
                  (set! new fst)
                  (if (or (not n?) (done? fst)) collect-final r))
                r))))))

(define (function->iterator f &optional done? include-last?)
  (define arity
    (cond [(procedure-arity-includes? f 0) 0]
          [(procedure-arity-includes? f 1) 1]
          [else (error 'function->iterator
                       "don't know how to iterate over function ~e" f)]))
  (when (and done? include-last?)
    (set! done?
          (let ([d? done?])
            (lambda (x) (when (d? x) (set! f (lambda _ collect-final))) #f))))
  (when (eq? 1 arity) (set! f (function-iterator f collect-final)))
  (list (void) void #f
        (if done?
          (lambda (_)
            (let ([x (f)])
              (if (or (eq? x collect-final) (done? x)) collect-final x)))
          (lambda (_) (f)))))

;;>   Iteration is possible on one of the following sequence values:
(define* (collect-iterator seq)
  (define (out-of-range r) (lambda (x) (<= r x)))
  (cond
;;>   * list: iterate over the list's element;
   [(list? seq) (list seq cdr null? car)]
;;>   * vector: iterate over the vector's elements;
   [(vector? seq) (list 0 add1 (out-of-range (vector-length seq))
                        (lambda (i) (vector-ref seq i)))]
;;>   * string: iterate over characters in the string;
   [(string? seq) (list 0 add1 (out-of-range (string-length seq))
                        (lambda (i) (string-ref seq i)))]
;;>   * integer n: iterate on values from 0 to n-1;
   [(integer? seq) (list 0 add1 (out-of-range seq) #f)]
;;>   * procedure f:
   [(procedure? seq)
;;>     - if f accepts zero arguments, begin with (f) and iterate by
;;>       re-applying (f) over and over, so the only way to end this
;;>       iteration is by returning `collect-final' (see below);
;;>     - otherwise, if f accepts one argument, it is taken as a generator
;;>       function: it is passed a one-argument procedure `yield' which can
;;>       be used to suspend its execution returning the given value, and it
;;>       will be continued when more values are required (see
;;>       `function-iterator' below);
    (function->iterator seq)]
;;>   * hash-table: iterate over key-value pairs -- this is done with a
;;>     generator function:
;;>       (lambda (yield)
;;>         (hash-table-for-each seq (lambda (k v) (yield (cons k v)))))
   [(hash-table? seq)
    (collect-iterator (lambda (yield)
                        (hash-table-for-each
                         seq (lambda (k v) (yield (cons k v))))))]
;;>   * other values: repeated infinitely.
   [else (list seq identity #f #f)]))
;;>   Note that iteration over non-lists is done efficiently, iterating over
;;>   a vector `v' is better than iterating over `(vector->list v)'.
;;>

;;>   Enumeration is used whenever a ".." token is used to specify a range.
;;>   There are different enumeration types based on different input types,
;;>   and all are modified by the token used:
;;>   * "..": a normal inclusive range;
;;>   * "..<": a range that does not include the last element;
;;>   * ".. while": a range that continues while a predicate is true;
;;>   * ".. until": a range that continues until a predicate is true.
;;>   The "..<" token extends to predicates in the expected way: the element
;;>   that satisfies the predicate is the last one and it is not included in
;;>   the enumeration -- unlike "..".
;;>   These are the possible types that can be used with an enumeration:
(define* (collect-numerator from second to &optional flag)
  (define (check-type pred? &optional not-to)
    (and (pred? from) (or (not second) (pred? second))
         (or not-to (not to) (pred? to))))
  (define (to->pred)
    (and to (let ([to (if (and (procedure? to)
                               (procedure-arity-includes? to 1))
                        to (lambda (x) (equal? x to)))])
              (if (eq? 'while flag) (negate to) to))))
  (when (and (memq flag '(while until))
             (not (and (procedure? to) (procedure-arity-includes? to 1))))
    (set! to (lambda (x) (equal? x to))))
;;>   * num1 [num2] .. [num3]: go from num1 to num3 in num3 in num2-num1
;;>     steps, if num2 is not given then use +1/-1 steps, if num3 is not
;;>     given don't stop;
;;>   * num1 [num2] .. pred: go from num1 by num2-num1 steps (defaults to
;;>     1), up to the number that satisfies the given predicate;
  (cond [(check-type number?)
         (let* ([step
                 (cond [second (- second from)]
                       [(and (number? to) (> from to)) -1]
                       [else 1])]
                [gt?
                 (case flag
                   [(#f) (if (positive? step) > <)]
                   [(<)  (if (positive? step) >= <=)]
                   [else (error 'collect-numerator "internal error")])])
           (list from
                 (lambda (x) (+ x step))
                 (if (number? to) (lambda (x) (gt? x to)) #f)
                 #f))]
;;>   * char1 [char2] .. [char3/pred]: the same as with numbers, but on
;;>     character ranges;
        [(check-type char? #t)
         (let ([numerator (collect-numerator
                           (char->integer from)
                           (and second (char->integer second))
                           (cond [(char? to) (char->integer to)]
                                 [(and (procedure? to)
                                       (procedure-arity-includes? to 1))
                                  (compose to integer->char)]
                                 [else to])
                           flag)])
           (list (1st numerator) (2nd numerator) (3rd numerator)
                 integer->char))]
;;>   * func .. [pred/x]: use `func' the same way as in an iterator above,
;;>     use `pred' to identify the last element, if `pred' is omitted repeat
;;>     indefinitely;
        [(and (procedure? from) (not second))
         (let ([to (to->pred)])
           (function->iterator from to (and (not flag) to)))]
;;>   * fst [next] .. [pred]: start with `fst', continue by repeated
;;>     applications of the `next' function on it, and use `pred' to
;;>     identify the last element, if `pred' is omitted repeat indefinitely,
;;>     if `next' is omitted repeat `fst', and if both `fst' and `next' are
;;>     numbers or characters then use their difference for stepping.  (Note
;;>     that to repeat a function value you should use `identity' as for
;;>     `next' or the function will be used as described above.)
        [else
         (cond [(and (number? from) (number? second))
                (let ([d (- second from)]) (set! second (lambda (x) (+ x d))))]
               [(not second) (set! second identity)]
               [(not (and (procedure? second)
                          (procedure-arity-includes? second 1)))
                (error 'collect-numerator
                       "don't know how to enumerate ~e ~e .. ~e"
                       from second to)])
         (if (not to)
           (list from second #f #f)
           (let ([to (to->pred)])
             (if (or flag (not to))
               (list from second to #f)
               (let ([almost-done? (to from)] [done? #f])
                 (list from (lambda (x)
                              (if almost-done?
                                (set! done? #t)
                                (let ([next (second x)])
                                  (when (to next) (set! almost-done? #t))
                                  next)))
                       (lambda (_) done?) #f)))))]))
;;>

;;>   Here is a long list of examples for clarification, all using
;;>   `list-of', but the generalization should be obvious:
;;>     => (list-of x [x <- '(1 2 3)])
;;>     (1 2 3)
;;>     => (list-of (list x y) [x <- '(1 2 3)] [y <- 1 .. 2])
;;>     ((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))
;;>     => (list-of (format "~a~a~a" x y z)
;;>                 [x <- '(1 2)] [y <- #(a b)] [z <- "xy"])
;;>     ("1ax" "1ay" "1bx" "1by" "2ax" "2ay" "2bx" "2by")
;;>     => (list-of (+ x y) [x <- '(1 2 3)] [y <- 20 40 .. 100])
;;>     (21 41 61 81 101 22 42 62 82 102 23 43 63 83 103)
;;>     => (list-of (+ x y) [x <- '(1 2 3) and y <- 20 40 .. 100])
;;>     (21 42 63)
;;>     => (list-of y [x <- 0 .. and y <- '(a b c d e f g h i)] (even? x))
;;>     (a c e g i)
;;>     => (list-of y [x <- 0 .. and y <- '(a b c d e f g h i)]
;;>          when (even? x) do (echo y))
;;>     a
;;>     c
;;>     e
;;>     g
;;>     i
;;>     (a c e g i)
;;>     => (list-of (list x y) [x <- 3 and y <- 'x])
;;>     ((0 x) (1 x) (2 x))
;;>     => (list-of (list x y) [x <- 3 and y <- 'x ..])
;;>     ((0 x) (1 x) (2 x))
;;>     => (list-of (list x y) [x <- #\0 .. and y <- '(a b c d)])
;;>     ((#\0 a) (#\1 b) (#\2 c) (#\3 d))
;;>     => (list-of x [x <- '(1 2 3) then (cdr x) until (null? x)])
;;>     ((1 2 3) (2 3) (3))
;;>     => (list-of (list x y)
;;>          [x <- '(1 2 3) then (cdr y) until (null? x) and
;;>           y <- '(10 20 30) then (cdr x) until (null? y)])
;;>     (((1 2 3) (10 20 30)) ((20 30) (2 3)) ((3) (30)))
;;>     => (list-of x [x <- (lambda (yield) 42)])
;;>     ()
;;>     => (list-of x [x <- (lambda (yield) (yield 42))])
;;>     (42)
;;>     => (list-of x [x <- (lambda (yield) (yield (yield 42)))])
;;>     (42 42)
;;>     => (list-of x [x <- (lambda (yield)
;;>                           (for-each (lambda (x) (echo x) (yield x))
;;>                                     '(3 2 1 0)))])
;;>     3
;;>     2
;;>     1
;;>     0
;;>     (3 2 1 0)
;;>     => (list-of x [x <- (lambda (yield)
;;>                           (for-each (lambda (x) (echo x) (yield (/ x)))
;;>                                     '(3 2 1 0)))])
;;>     3
;;>     2
;;>     1
;;>     0
;;>     /: division by zero
;;>     => (list-of x
;;>          [c <- 3 and
;;>           x <- (lambda (yield)
;;>                  (for-each (lambda (x) (echo x) (yield (/ x)))
;;>                            '(3 2 1 0)))])
;;>     3
;;>     2
;;>     1
;;>     (1/3 1/2 1)
;;>     => (define h (make-hash-table))
;;>     => (set! (hash-table-get h 'x) 1
;;>              (hash-table-get h 'y) 2
;;>              (hash-table-get h 'z) 3)
;;>     => (list-of x [x <- h])
;;>     ((y . 2) (z . 3) (x . 1))
;;>     => (list-of x [x <- 4 <- 4 .. 0 <- '(1 2 3)])
;;>     (0 1 2 3 4 3 2 1 0 1 2 3)
;;>     => (list-of (list x y)
;;>          [x <- 1 .. 3 <- '(a b c) and
;;>           y <- (lambda (y) (y 'x) (y 'y)) <- "abcd"])
;;>     ((1 x) (2 y) (3 #\a) (a #\b) (b #\c) (c #\d))
;;>
;;>   Note that parallel iteration is useful both for enumerating results,
;;>   and for walking over a finite prefix of an infinite iteration.
;;>
;;>   The following is an extensive list of various ranges:
;;>     => (list-of x [x <- 0 .. 6])
;;>     (0 1 2 3 4 5 6)
;;>     => (list-of x [x <- 0 ..< 6])
;;>     (0 1 2 3 4 5)
;;>     => (list-of x [x <- 0 .. -6])
;;>     (0 -1 -2 -3 -4 -5 -6)
;;>     => (list-of x [x <- 0 ..< -6])
;;>     (0 -1 -2 -3 -4 -5)
;;>     => (list-of x [x <- 0 2 .. 6])
;;>     (0 2 4 6)
;;>     => (list-of x [x <- 0 2 ..< 6])
;;>     (0 2 4)
;;>     => (list-of x [x <- 0 -2 ..< -6])
;;>     (0 -2 -4)
;;>     => (list-of x [x <- #\a .. #\g])
;;>     (#\a #\b #\c #\d #\e #\f #\g)
;;>     => (list-of x [x <- #\a ..< #\g])
;;>     (#\a #\b #\c #\d #\e #\f)
;;>     => (list-of x [x <- #\a #\c .. #\g])
;;>     (#\a #\c #\e #\g)
;;>     => (list-of x [x <- #\a #\c ..< #\g])
;;>     (#\a #\c #\e)
;;>     => (list-of x [x <- #\g #\e ..< #\a])
;;>     (#\g #\e #\c)
;;>     => (list-of x [x <- 6 5 .. zero?])
;;>     (6 5 4 3 2 1 0)
;;>     => (list-of x [x <- 6 5 ..< zero?])
;;>     (6 5 4 3 2 1)
;;>     => (list-of x [x <- 6 5 .. until zero?])
;;>     (6 5 4 3 2 1)
;;>     => (list-of x [x <- 6 5 .. while positive?])
;;>     (6 5 4 3 2 1)
;;>     => (list-of x [x <- '(1 2 3) cdr .. null?])
;;>     ((1 2 3) (2 3) (3) ())
;;>     => (list-of x [x <- '(1 2 3) cdr ..< null?])
;;>     ((1 2 3) (2 3) (3))
;;>     => (list-of x [x <- '(1 2 3) cdr .. until null?])
;;>     ((1 2 3) (2 3) (3))
;;>     => (list-of x [x <- '(1 2 3) cdr .. while pair?])
;;>     ((1 2 3) (2 3) (3))
;;>     => (list-of x [x <- #\a #\d .. while char-alphabetic?])
;;>     (#\a #\d #\g #\j #\m #\p #\s #\v #\y)
;;>     => (list-of x [x <- #\a #\d .. char-alphabetic?])
;;>     (#\a)
;;>     => (list-of x [x <- #\a #\d ..< char-alphabetic?])
;;>     ()
;;>     => (list-of x [x <- 0 1 .. positive?])
;;>     (0 1)
;;>     => (list-of x [x <- 1 2 .. positive?])
;;>     (1)
;;>     => (list-of x [x <- 1 2 ..< positive?])
;;>     ()
;;>     => (list-of x [x <- '(a b c) ..< pair?])
;;>     ()
;;>     => (list-of x [x <- '(a b c) .. pair?])
;;>     ((a b c))
;;>     => (list-of x [x <- '(a b c) cdr .. pair?])
;;>     ((a b c))
;;>     => (list-of x [x <- read-line .. eof-object?])
;;>     ...list of remaining input lines, including #<eof>...
;;>     => (list-of x [x <- read-line ..< eof-object?])
;;>     ...list of remaining input lines, excluding #<eof>...
;;>     => (list-of x [x <- read-line ..< eof])
;;>     ...the same...
;;>

;;>> collect-final
;;>   This value can be used to terminate iterations: when it is returned as
;;>   the iteration value (not the state), the iteration will terminate
;;>   without using it.
(define* collect-final (list "*"))

;;>> (function-iterator f [final-value])
;;>   `f' is expected to be a function that can accept a single input value.
;;>   It is applied on a `yield' function that can be used to return a value
;;>   at any point.  The return value is a function of no argument, which
;;>   returns on every application values that were passed to `yield'.  When
;;>   `f' terminates, the final result of the iterated return value depends
;;>   on the optional argument -- if none was supplied, the actual return
;;>   value is returned, if a thunk was supplied it is applied for a return
;;>   value, and if any other value was given it is returned.  After
;;>   termination, calling the iterated function again results in an error.
;;>   (The supplied `yield' function returns its supplied value to the
;;>   calling context when resumed.)
;;>     => (define (foo yield) (yield 1) (yield 2) (yield 3))
;;>     => (define bar (function-iterator foo))
;;>     => (list (bar) (bar) (bar))
;;>     (1 2 3)
;;>     => (bar)
;;>     3
;;>     => (bar)
;;>     function-iterator: iterated function #<procedure:foo> exhausted.
;;>     => (define bar (function-iterator foo 'done))
;;>     => (list (bar) (bar) (bar) (bar))
;;>     (1 2 3 done)
;;>     => (bar)
;;>     function-iterator: iterated function #<procedure:foo> exhausted.
;;>     => (define bar (function-iterator foo (thunk (error 'foo "done"))))
;;>     => (list (bar) (bar) (bar))
;;>     (1 2 3)
;;>     => (bar)
;;>     foo: done
(define* (function-iterator f . finally)
  (define ret #f)
  (define (done)
    (set! cnt (thunk (error 'function-iterator
                            "iterated function ~e exhausted." f))))
  (define cnt
    (cond [(null? finally) (thunk (let ([r (f yield)]) (done) (ret r)))]
          [(and (procedure? (car finally))
                (procedure-arity-includes? (car finally) 0))
           (thunk (f yield) (done) (ret ((car finally))))]
          [else (thunk (f yield) (done) (ret (car finally)))]))
  (define (yield v) (let/cc k (set! cnt (thunk (k v))) (ret v)))
  (thunk (let/cc ret1 (set! ret ret1) (cnt))))

;;>> (collect-iterator sequence)
;;>> (collect-numerator from second to [flag])
;;>   These functions are used to construct iterations.  `collect-iterator'
;;>   is the function used to create iteration over a sequence object and it
;;>   is used by `(x <- sequence)' forms of `collect'.  `collect-numerator'
;;>   create range iterations specified with `(x <- from second to)' forms,
;;>   where unspecified values are passed as `#f', and the flag argument is
;;>   a `<', `while', or `until' symbol for ranges specified with "..<",
;;>   ".. while" and ".. until".  These functions are available for
;;>   implementing new iteration constructs, for example:
;;>     => (define (in-values producer)
;;>          (collect-iterator (call-with-values producer list)))
;;>     => (list-of x [x <- in-values (thunk (values 1 2 3))])
;;>     (1 2 3)
;;>   The return value that specifies an iteration is a list of four items:
;;>   1. the initial state value;
;;>   2. a `step' function that gets a state and returns the next one;
;;>   3. a predicate for the end state (#f for none);
;;>   4. a function that computes a value from the state variable.
;;>   But usually the functions are more convenient.
;;>
;;>   Finally, remember that you can return `collect-final' as the value to
;;>   terminate any iteration.

;; ----------------------------------------------------------------------------
;;>>... Convenient printing

;;>> *echo-display-handler* [h]
;;>> *echo-write-handler*   [h]
;;>   Currently, MzScheme's I/O can be customized only on a per port basis.
;;>   This means that installing the object printing generic later will
;;>   change only the standard ports, and for new ports a handleres should
;;>   always be installed.  This means that `echos' will not work with
;;>   objects since it uses a new port -- so use these parameters to allow
;;>   to change them later to the Swindle printer.
(define* *echo-display-handler* (make-parameter display))
(define* *echo-write-handler* (make-parameter write))

;;>> (echo arg ...)
;;>   This is a handy printout utility that offers an alternative approach
;;>   to `printf'-like output (it's a syntax, but it can be used as a
;;>   regular function too, see below).  When applied, it simply prints its
;;>   arguments one by one, using certain keywords to control its behavior:
;;>   * :>e     - output on the current-error-port;
;;>   * :>o     - output on the current-output-port (default);
;;>   * :>s     - accumulate output in a string which is the return value
;;>               (string output sets `:n-' as default (unless
;;>               pre-specified));
;;>   * :> p    - output on the given port `p', or a string if `#f';
;;>   * :>> o   - use `o', a procedure that gets a value and a port, as the
;;>               output handler (the procedure can take one value and
;;>               display it on the current output port);
;;>   * :d      - use `display' output (default);
;;>   * :w      - use `write' output;
;;>   * :d1 :w1 - change to a `display' or `write' output just for the next
;;>               argument;
;;>   * :s-     - no spaces between arguments;
;;>   * :s+     - add spaces between arguments (default);
;;>   * :n-     - do not print a final newline;
;;>   * :n+     - terminate the output with a newline (default);
;;>   * :n      - output a newline now;
;;>   * : or :: - avoid a space at this point;
;;>   * :\{     - begin a list construct (see below).
;;>   Keywords that require additional argument are ignored if no argument
;;>   is given.
;;>
;;>   Recursive processing of a list begins with a `:\{' and ends with a
;;>   `:\}' (which can be simpler if `read-curly-brace-as-paren' is off).
;;>   Inside a list context, values are inspected and any lists cause
;;>   iteration for all elements.  In each iteration, all non-list arguments
;;>   are treated normally, but lists are dissected and a single element is
;;>   printed in each step, terminating when the shortest list ends (and
;;>   repeating a last `dotted' element of a list):
;;>     => (define abc '(a b c))
;;>     => (echo :\{ "X" abc :\})
;;>     X a X b X c
;;>     => (echo :\{ "X" abc '(1 2 3 4) :\})
;;>     X a 1 X b 2 X c 3
;;>     => (echo :\{ "X" abc '(1 . 2) :\})
;;>     X a 1 X b 2 X c 2
;;>   Inside a list context, the `:^' keyword can be used to stop this
;;>   iteration if it is the last:
;;>     => (echo :s- :\{ abc :^ ", " :\})
;;>     a, b, c
;;>   Nesting of lists is also simple, following these simple rules, by
;;>   nesting the `:\{' ... `:\}' construct:
;;>     => (echo :s- :\{ "<" :\{ '((1 2) (3 4 5) 6 ()) :^ "," :\} ">"
;;>                      :^ "-" :\})
;;>     <1,2>-<3,4,5>-<6>-<>
;;>   Note that this example is similar to the CL `format':
;;>     (format t "~{<~{~a~^,~}>~^-~}" '((1 2) (3 4 5) 6 ()))
;;>   except that `echo' treats a dotted element (a non-list in this case)
;;>   as repeating as needed.
;;>
;;>   There are two additional special keywords that are needed only in
;;>   uncommon situations:
;;>   * :k-  - turn off keyword processing
;;>   * :k+  - turn keyword processing on
;;>   Usually, when `echo' is used, it is processed by a macro that detects
;;>   all keywords, even if there is a locally bound variable with a keyword
;;>   name.  This means that keywords are only ones that are syntactically
;;>   so, not expressions that evaluate to keywords.  The two cases where
;;>   this matters are -- when `echo' is used for its value (using it as a
;;>   value, not in a head position) no processing is done so all keywords
;;>   will just get printed; and when `echo' is used in a context where a
;;>   variable has a keyword name and you want to use its value (which not a
;;>   great idea anyway, so there is no way around it).  The first case is
;;>   probably more common, so the variable `echo:' is bound to a special
;;>   value that will force treating the next value as a keyword (if it
;;>   evaluates to one) -- it can also be used to turn keyword processing on
;;>   (which means that all keyword values will have an effect).  Here is a
;;>   likely examples where `echo:' should be used:
;;>     => (define (echo-values vals)
;;>          (apply echo "The given values are:" echo: :w vals))
;;>     => (echo-values '("a" "b" "c"))
;;>     The given values are: "a" "b" "c"
;;>     => (echo-values '(:a :b :c))
;;>     The given values are: :a :b :c
;;>   And here are some tricky examples:
;;>     => (echo :>s 2)
;;>     "2"
;;>     => (define e echo)                 ; `e' is the real `echo' function
;;>     => (e :>s 2)                       ; no processing done here
;;>     :>s 2
;;>     => (e echo: :>s 2)                 ; explicit key
;;>     "2"
;;>     => (e echo: :k+ :>s 2)             ; turn on keywords
;;>     "2"
;;>     => (let ([:>s 1]) (echo :>s 2))    ; `:>s' was processed by `echo'
;;>     "2"
;;>     => (let ([:>s 1]) (e :>s 2))       ; `:>s' was not processed
;;>     1 2
;;>     => (let ([:>s 1]) (e echo: :>s 2)) ; `:>s' is not a keyword here!
;;>     1 2
;;>     => (let ([:>s 1]) (echo echo: :>s 2)) ; `echo:' not needed
;;>     "2"
;;>
;;>   Finally, it is possible to introduce new keywords to `echo'.  This is
;;>   done by calling it with the `:set-user' keyword, which expects a
;;>   keyword to attach a handler to, and the handler itself.  The handler
;;>   can be a simple value or a keyword that will be used instead:
;;>     => (echo :set-user :foo "foo")
;;>     => (echo 1 :foo 2)
;;>     1 foo 2
;;>     => (echo :set-user :foo :n)
;;>     => (echo 1 :foo 2)
;;>     1
;;>     2
;;>   The `:set-user' keyword can appear with other arguments, it has a
;;>   global effect in any case:
;;>     => (echo 1 :foo :set-user :foo "FOO" 2 :foo 3
;;>              :set-user :foo "bar" :foo 4)
;;>     1
;;>     2 FOO 3 bar 4
;;>     => (echo 1 :foo 2)
;;>     1 bar 2
;;>   If the handler is a function, then when this keyword is used, the
;;>   function is applied on arguments pulled from the remaining `echo'
;;>   arguments that follow (if the function can get any number of
;;>   arguments, then all remaining arguments are taken).  The function can
;;>   work in two ways: (1) when it is called, the `current-output-port'
;;>   will be the one that `echo' currently prints to, so it can just print
;;>   stuff; (2) if the function returns a list (or a single value which is
;;>   not `#f' or `void'), then these values will be used instead of the
;;>   taken arguments.  Some examples:
;;>     => (echo :set-user :foo (thunk "FOO") 1 :foo 2)
;;>     1 FOO 2
;;>     => (echo :set-user :add1 add1 1 :add1 2)
;;>     1 3
;;>     => (echo :set-user :+1 (lambda (n) (list n '+1= (add1 n))) :+1 2)
;;>     2 +1= 3
;;>     => (echo :set-user :<> (lambda args (append '("<") args '(">")))
;;>              :<> 1 2 3)
;;>     < 1 2 3 >
;;>   Care should be taken when user keywords are supposed to handle other
;;>   keywords -- the `echo:' tag will usually be among the arguments except
;;>   when `:k+' was used and an argument value was received.  This exposes
;;>   the keyword treatment hack and might change in the future.
;;>
;;>   To allow user handlers to change settings temporarily, there are
;;>   `:push' and `:pop' keywords that will save and restore the current
;;>   state (space and newline flags, output type and port etc).  For
;;>   example:
;;>     => (echo :set-user :@
;;>              (lambda (l)
;;>                (echo-quote
;;>                 list :push :s- :\{ "\"" l "\"" :^ ", " :\} :pop)))
;;>     => (echo 1 :@ '(2 3 4) 5)
;;>     1 "2", "3", "4" 5
;;>   The above example shows another helper tool -- the `echo-quote'
;;>   syntax: `(echo-quote head arg ...)' will transform into `(head ...)',
;;>   where keyword arguments are prefix with the `echo:' tag.  Without it,
;;>   things would look much worse.
;;>
;;>   In addition to `:set-user' there is an `:unset-user' keyword which
;;>   cancels a keyword handler.  Note that built-in keywords cannot be
;;>   overridden or unset.

;;>> (echo-quote head arg ...) [h]
;;>   This macro will result in `(head arg ...)', where all keywords in the
;;>   argument list are preceded with the `echo:' tag.  It is a convenient
;;>   form to use for defining new echo keyword handlers.
(defsyntax* (echo-quote stx)
  (define (process args)
    (syntax-case args ()
      [() #'()]
      [(x . more) (with-syntax ([more (process #'more)])
                    (if (syntax-keyword? #'x)
                      ;; `datum' protects from using a local binding
                      #'(echo: (#%datum . x) . more) #'(x . more)))]
      [x #'x])) ; only in case of (echo ... . x)
  (syntax-case stx ()
    [(_ head . args) (quasisyntax/loc stx (head . #,(process #'args)))]))

(provide (rename echo-syntax echo))
(defsyntax (echo-syntax stx)
  (syntax-case stx ()
    [(_ . args) (syntax/loc stx (echo-quote echo . args))]
    [_ #'echo]))

;; A table for user-defined keywords
(define echo-user-table (make-hash-table))

;; Make an echo keyword handler for a given procedure.  The handler gets the
;; current list of arguments and returns the new list of arguments.
(define (make-echo-handler keyword proc)
  (let* ([arity (procedure-arity proc)]
         [at-least (and (arity-at-least? arity)
                        (arity-at-least-value arity))]
         [required (or at-least arity)])
    (unless (integer? required)
      (error 'echo "handler function for `~e' has bad arity" keyword))
    (lambda (args)
      (if (< (length args) required)
        (error 'echo "user-keyword `~e' didn't get enough arguments" keyword)
        (let*-values ([(proc-args rest-args)
                       (if at-least
                         (values args '())
                         (let loop ([rest args] [args '()] [n required])
                           (if (zero? n)
                             (values (reverse! args) rest)
                             (loop (cdr rest) (cons (car rest) args)
                                   (sub1 n)))))]
                      [(result) (apply proc proc-args)])
          (cond [(list? result) (append result rest-args)]
                [(and result (not (void? result)))
                 (if (keyword? result)
                   (list* echo: result rest-args) (cons result rest-args))]
                [else rest-args]))))))

(define (echo . args)
  (define break: "break:")
  (define call:  "call:")
  (let ([printer (*echo-display-handler*)] [out (current-output-port)]
        [spaces? #t] [newline? 'x] [first? #t] [str? #f] [keys? #f]
        [states '()])
    (define (getarg) (begin0 (car args) (set! args (cdr args))))
    (define (push-state!)
      (set! states (cons (list printer out spaces? newline? first? str? keys?)
                         states)))
    (define (pop-state!)
      (if (null? states)
        (error 'echo "tried to restore a state, but none saved")
        (let ([s (car states)])
          (set! states (cdr states))
          (set!-values (printer out spaces? newline? first? str? keys?)
                       (apply values s)))))
    (define (set-out! arg)
      (set! out (or arg (open-output-string)))
      (set! str? (not arg))
      (unless (output-port? out)
        (error 'echo "expected an output-port or #f, given ~e" out)))
    (define (printer1! hparam)
      (unless (or (null? args) (eq? echo: (car args)))
        (let ([p (hparam)])
          (unless (eq? printer p)
            (let ([v (getarg)] [op printer])
              (set! printer p)
              (set! args (list* v echo: :>> op args)))))))
    (define (process-list)
      (define level 1)
      (define ((do-lists args))
        ;; this returns a thunk so the whole thing is not expanded in one shot
        (let loop ([args args] [cars '()] [cdrs '()] [last? '?])
          (if (null? args)
            (reverse!
             (if last? cars (list* (do-lists (reverse! cdrs)) call: cars)))
            (let* ([1st (car args)] [p? (pair? 1st)])
              (if (and last? (eq? 1st break:))
                (reverse! cars)
                (if (null? 1st)
                  '()
                  (loop (cdr args)
                        (if (eq? 1st break:)
                          cars (cons (if p? (car 1st) 1st) cars))
                        (cons (if p? (cdr 1st) 1st) cdrs)
                        (if p?
                          (or (eq? last? #t) (null? (cdr 1st)))
                          last?))))))))
      (let loop ([l-args '()])
        (define (pop-key-tags)
          (when (and (pair? l-args) (eq? echo: (car l-args)))
            (set! l-args (cdr l-args)) (pop-key-tags)))
        (when (null? args)
          (error 'echo "found a `~e' with no matching `~e'" :\{ :\}))
        (let ([arg (getarg)])
          (define (next) (loop (cons arg l-args)))
          (cond
           [(eq? arg echo:) (set! keys? (or keys? 'just-one)) (next)]
           [(and keys? (keyword? arg))
            (unless (eq? keys? #t) (set! keys? #f))
            (case arg
              [(:\})
               (set! level (sub1 level))
               (if (zero? level)
                 (begin
                   (pop-key-tags)
                   (set! args (append! ((do-lists (reverse! l-args))) args)))
                 (next))]
              [(:\{)
               (set! level (add1 level)) (next)]
              [(:^)
               (when (eq? 1 level) (set! arg break:) (pop-key-tags))
               (next)]
              [else (next)])]
           [else (next)]))))
    (let loop ()
      (unless (null? args)
        (let ([arg (getarg)])
          (cond
           [(eq? arg call:) (set! args (append! ((getarg)) args))]
           [(eq? arg echo:) (set! keys? (or keys? 'just-one))]
           [(and keys? (keyword? arg))
            (unless (eq? keys? #t) (set! keys? #f))
            (case arg
              [(:>e)    (set-out! (current-error-port))]
              [(:>o)    (set-out! (current-output-port))]
              [(:>s)    (set-out! #f)]
              [(:>)     (unless (or (null? args) (eq? echo: (car args)))
                          (set-out! (getarg)))]
              [(:>>)    (unless (or (null? args) (eq? echo: (car args)))
                          (let ([p (getarg)])
                            (set! printer (if (eq? 1 (procedure-arity p))
                                            (lambda (x _) (p x)) p))))]
              [(:d)     (set! printer (*echo-display-handler*))]
              [(:w)     (set! printer (*echo-write-handler*))]
              [(:d1)    (printer1! *echo-display-handler*)]
              [(:w1)    (printer1! *echo-write-handler*)]
              [(:s-)    (set! spaces? (and spaces? (not first?) 'just-one))]
              [(:s+)    (set! spaces? #t)]
              [(:n-)    (set! newline? #f)]
              [(:n+)    (set! newline? #t)]
              [(:n)     (newline out) (set! first? #t)]
              [(:: :)   (set! first? #t)]
              [(:push)  (push-state!)]
              [(:pop)   (pop-state!)]
              [(:\{)    (process-list)]
              [(:\} :^) (error 'echo "unexpected list keyword `~e'" arg)]
              [(:k-)    (set! keys? #f)]
              [(:k+)    (set! keys? #t)]
              [(:set-user :unset-user)
               (let loop ([keyword echo:])
                 (if (null? args)
                   (error 'echo "expecting a keyword+handler after `~e'" arg)
                   (let ([x (getarg)])
                     (cond
                      [(eq? keyword echo:) (loop x)]
                      [(not (keyword? keyword))
                       (error 'echo "got a `~e' with a non-keyword `~e'"
                              arg keyword)]
                      [(eq? arg :unset-user)
                       (hash-table-put! echo-user-table keyword #f)]
                      [(eq? x echo:) (loop keyword)]
                      [else (let ([handler (if (procedure? x)
                                             (make-echo-handler keyword x) x)])
                              (hash-table-put! echo-user-table keyword handler)
                              (when (and newline? (not (eq? #t newline))
                                         (null? args))
                                (set! newline? #f)))]))))]
              [else
               (let ([user (hash-table-get echo-user-table arg (thunk #f))])
                 (if user
                   (set! args
                         (cond [(procedure? user) (user args)]
                               [(keyword? user) (list* echo: user args)]
                               [else (cons user args)]))
                   (error 'echo "unknown keyword: `~e'" arg)))])]
           [first?  (printer arg out) (set! first? #f)]
           [spaces? (display " " out) (printer arg out)
                    (unless (eq? spaces? #t) (set! spaces? #f))]
           [else (printer arg out)])
          (loop))))
    (when (and newline? (or (not str?) (eq? newline? #t))) (newline out))
    (when str? (get-output-string out))))

;;>> (echos arg ...)
;;>   Just uses `echo' with `:>s'.
(provide (rename echos-syntax echos))
(defsyntax (echos-syntax stx)
  (syntax-case stx ()
    [(_ . args) (syntax/loc stx (echo-syntax :>s . args))]
    [_ #'echos]))
(define (echos . args)
  (echo echo: :>s . args))

;;>> echo:
;;>   See the `echo' description for usage of this value.
(define* echo: "echo:")

;; ----------------------------------------------------------------------------
;; Simple macros

;;>> (named-lambda name args body ...)
;;>   Like `lambda', but the name is bound to itself in the body.
(defsubst* (named-lambda name args . body)
  (letrec ([name (lambda args . body)]) name))

;;>> (thunk body ...)
;;>   Returns a procedure of no arguments that will have the given body.
(defsubst* (thunk body ...) (lambda () body ...))

;;>> (while condition body ...)
;;>> (until condition body ...)
;;>   Simple looping constructs.
(defsubst* (while cond body ...)
  (let loop () (when cond (begin body ... (loop)))))
(defsubst* (until cond body ...)
  (while (not cond) body ...))

;;>> (dotimes (i n) body ...)
;;>   Loop `n' times, evaluating the body when `i' is bound to 0,1,...,n-1.
(defsubst* (dotimes [i n] body0 body ...)
  (let loop ([i 0])
    (when (< i n) body0 body ... (loop (add1 i)))))

;;>> (dolist (x list) body ...)
;;>   Loop with `x' bound to elements of `list'.
(defsubst* (dolist [x lst] body0 body ...)
  (for-each (lambda (x) body0 body ...) lst))

;;>> (no-errors body ...)
;;>   Execute body, catching all errors and returning `#f' if one occurred.
(defsubst* (no-errors body ...)
  (with-handlers ([void (lambda (x) #f)]) body ...))
;;>> (no-errors* body ...)
;;>   Execute body, catching all errors and returnsthe exception if one
;;>   occured.
(defsubst* (no-errors* body ...)
  (with-handlers ([void identity]) body ...))

;;>> (regexp-case string clause ...)
;;>   Try to match the given `string' against several regexps.  Each clause
;;>   has one of the following forms:
;;>   * (re => function): if `string' matches `re', apply `function' on the
;;>     result list.
;;>   * ((re args ...) body ...): if `string' matches `re', bind the tail of
;;>     results (i.e, excluding the whole match result) to the given
;;>     arguments and evaluate the body.  The whole match result (the first
;;>     element of `regexp-match') is bound to `match'.
;;>   * (re body ...): if `string' matches `re', evaluate the body -- no
;;>     match results are available.
;;>   * (else body ...): should be the last clause which is evaluated if all
;;>     previous cases failed.
(defsyntax* (regexp-case stx)
  (define (do-clause c)
    (syntax-case c (else =>)
      [(else body ...) c]
      [(re => func) #'((regexp-match re s) => (lambda (r) (apply func r)))]
      [((re . args) body ...)
       #`((regexp-match re s) =>
          (lambda (r)
            (apply (lambda (#,(datum->syntax-object c 'match c) . args)
                     body ...)
                   r)))]
      [(re body ...) #'((regexp-match re s) body ...)]))
  (define (do-clauses c)
    (cond [(null? c) c]
          [(pair? c) (cons (do-clause (car c)) (do-clauses (cdr c)))]
          [(syntax? c) (do-clauses (syntax-e c))]))
  (syntax-case stx ()
    [(_ str clause ...)
     #`(let ([s str]) (cond #,@(do-clauses #'(clause ...))))]))

;; ----------------------------------------------------------------------------
;; Taken from slib (faster than then quicksort and mergesort in list.ss).
;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)

;;>>... Sorting
;;> The following section defines functions for sorting.  They are taken
;;> directly from slib since they are more convenient and faster than the
;;> functions in mzlib/list.  See the source for more details.

;;>> (sorted? sequence less?)
;;>   True when `sequence' is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;>   such that its elements are sorted according to `less?':
;;>     (not (less? (list-ref list i) (list-ref list (- i 1)))).
(define* (sorted? seq less?)
  (cond [(null? seq) #t]
        [(vector? seq)
         (let ([n (vector-length seq)])
           (if (<= n 1)
             #t
             (do ([i 1 (+ i 1)])
                 [(or (= i n)
                      (less? (vector-ref seq i) (vector-ref seq (- i 1))))
                  (= i n)])))]
        [else
         (let loop ([last (car seq)] [next (cdr seq)])
           (or (null? next)
               (and (not (less? (car next) last))
                    (loop (car next) (cdr next)))))]))

;;>> (merge a b less?)
;;>   Takes two lists `a' and `b' such that both (sorted? a less?) and
;;>   (sorted? b less?) are true, and returns a new list in which the
;;>   elements of `a' and `b' have been stably interleaved so that (sorted?
;;>   (merge a b less?) less?) is true.  Note: this does not accept vectors.
(define* (merge a b less?)
  (cond [(null? a) b]
        [(null? b) a]
        [else (let loop ([x (car a)] [a (cdr a)] [y (car b)] [b (cdr b)])
                ;; The loop handles the merging of non-empty lists.  It has
                ;; been written this way to save testing and car/cdring.
                (if (less? y x)
                  (if (null? b)
                    (cons y (cons x a))
                    (cons y (loop x a (car b) (cdr b))))
                  ;; x <= y
                  (if (null? a)
                    (cons x (cons y b))
                    (cons x (loop (car a) (cdr a) y b)))))]))

;;>> (merge! a b less?)
;;>   Takes two sorted lists `a' and `b' and smashes their cdr fields to
;;>   form a single sorted list including the elements of both.  Note: this
;;>   does not accept vectors.
(define* (merge! a b less?)
  (define (loop r a b)
    (if (less? (car b) (car a))
      (begin (set-cdr! r b)
             (if (null? (cdr b))
               (set-cdr! b a)
               (loop b a (cdr b))))
      ;; (car a) <= (car b)
      (begin (set-cdr! r a)
             (if (null? (cdr a))
               (set-cdr! a b)
               (loop a (cdr a) b)))))
  (cond [(null? a) b]
        [(null? b) a]
        [(less? (car b) (car a))
         (if (null? (cdr b))
           (set-cdr! b a)
           (loop b a (cdr b)))
         b]
        [else ; (car a) <= (car b)
         (if (null? (cdr a))
           (set-cdr! a b)
           (loop a (cdr a) b))
         a]))

;;>> (sort! sequence less?)
;;>   Sorts the list or vector `sequence' destructively.
;; It uses a version of merge-sort invented, to the best of my knowledge, by
;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;; R. A. O'Keefe adapted it to work destructively in Scheme.
(define* (sort! seq less?)
  (define (step n)
    (cond [(> n 2) (let* ([j (quotient n 2)]
                          [a (step j)]
                          [k (- n j)]
                          [b (step k)])
                     (merge! a b less?))]
          [(= n 2) (let ([x (car seq)]
                         [y (cadr seq)]
                         [p seq])
                     (set! seq (cddr seq))
                     (when (less? y x)
                       (set-car! p y) (set-car! (cdr p) x))
                     (set-cdr! (cdr p) '())
                     p)]
          [(= n 1) (let ([p seq])
                     (set! seq (cdr seq))
                     (set-cdr! p '())
                     p)]
          [else '()]))
  (if (vector? seq)
    (let ([n (vector-length seq)] [vec seq])
      (set! seq (vector->list seq))
      (do ([p (step n) (cdr p)] [i 0 (+ i 1)])
          [(null? p) vec]
        (vector-set! vec i (car p))))
    ;; otherwise, assume it is a list
    (step (length seq))))

;;>> (sort sequence less?)
;;>   Sorts a vector or list non-destructively.  It does this by sorting a
;;>   copy of the sequence.
;; My understanding is that the Standard says that the result of append is
;; always "newly allocated" except for sharing structure with "the last
;; argument", so (append x '()) ought to be a standard way of copying a list x.
(define* (sort seq less?)
  (if (vector? seq)
    (list->vector (sort! (vector->list seq) less?))
    (sort! (append seq '()) less?)))

)