#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2015-2019, Juergen Lorenz
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

Neither the name of the author nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|#

; This is a variant of the datatype egg, written by Felix Winkelmann,
; which in turn is patterned after the datatype facility described in
; the classic "Essentials of programming languages" (EOPL) by Friedman,
; Wand and Haynes. It changes the names and syntax a little and adds
; abstract as well as object types.

; Algebraic types are implemented by messages, which are vectors tagged
; with a type- and a variant-key.  Destructuring of algebraic types can
; be done more or less with bind-case from the bindings egg.

; Abstract types hide the constructors of its implementing algebraic
; types like the corresponding language construct of ML, and instances
; of object types are message-handlers, procedures with state, where the
; messages are defined as algebraic-types. 

(module messages (
  ;message-exception
  messages
  make-message
  message?
  message-of?
  message-key
  message-type
  message-data
  case-variant
  define-algebraic-type
  define-abstract-type
  define-object-type
  )
  
  (import scheme
          (only bindings bind bind-case)
          (only checks <<<)
          ;(only simple-exceptions make-exception raise)
          (only (chicken keyword) keyword?)
          (only (chicken syntax) define-for-syntax begin-for-syntax)
          (only (chicken base) define-record-type error print gensym
                receive call/cc case-lambda subvector define-values define-inline fixnum?)
          (only (chicken fixnum) fx+ fx- fx>= fx=)
          (only (chicken read-syntax) define-reader-ctor)
          (only (chicken condition) condition-case)
          functional-vectors
          )

  (import-for-syntax (only symbol-name-utils
                           symbol->keyword
                           keyword->symbol)
                     (only (chicken keyword) keyword?)
                     (only (chicken base) symbol-append)
                     ;(only srfi-1 split-at list-index)
                     )

;;; exceptions
;;; ----------
;(define message-exception
;  (make-exception "message exception" 'message))

(define-for-syntax (split-with where? lst)
  (let loop ((tail lst) (head '()))
    (cond
      ((null? tail)
       (values (reverse head) tail))
      ((where? (car tail))
       (values (reverse head) tail))
      (else
        (loop (cdr tail) (cons (car tail) head))))))

;;;; vector-implementation of messages
;;;; =================================
;
;;;; (make-message type-key key . args)
;;;; ----------------------------------
;(define (make-message type key . args)
;  (vector type key (apply vector args)))
;
;;;; (message? xpr)
;;;; --------------
;(define (message? xpr)
;  (and (vector? xpr)
;       (= 3 (vector-length xpr))
;       (keyword? (vector-ref xpr 0))
;       (keyword? (vector-ref xpr 1))
;       (vector? (vector-ref xpr 2))))
;
;;;; (message-type msg)
;;;; ------------------
;;;; returns the type key of the message
;(define (message-type msg)
;  (vector-ref msg 0))
;
;;;; (message-key msg)
;;;; -----------------
;;;; returns the key of the message
;(define (message-key msg)
;  (vector-ref msg 1))
;
;;;; (message-data msg)
;;;; ------------------
;;;; returns the data vector of the message
;(define (message-data msg)
;  (vector-ref msg 2))

;;; functional vector implementation of messages
;;; ============================================
;
;;; (make-message type-key key . args)
;;; ----------------------------------
(define (make-message type key . args)
  (fvector type key (apply fvector args)))

;;; (message? xpr)
;;; --------------
(define (message? xpr)
  (and (fvector? xpr)
       (= 3 (fvector-length xpr))
       (keyword? (fvector-ref xpr 0))
       (keyword? (fvector-ref xpr 1))
       (fvector? (fvector-ref xpr 2))))

;;; (message-type msg)
;;; ------------------
;;; returns the type key of the message
(define (message-type msg)
  (fvector-ref msg 0)) ;(msg 0))

;;; (message-key msg)
;;; -----------------
;;; returns the key of the message
(define (message-key msg)
  (fvector-ref msg 1)) ;(msg 1))

;;; (message-data msg)
;;; ------------------
;;; returns the data vector of the message
(define (message-data msg)
  (list->vector (caddr (fvector-data msg))))

;;; (message-of? type-key)
;;; ----------------------------
;;; returns a predicate which checks, if its only argument
;;; is a message of the given type-key
(define (message-of? name)
  (lambda (msg)
    (eq? (message-type msg) name)))

;;; (case-variant Child msg (key args . body) ....)
;;; -----------------------------------------------
;;; matches msg againes each variant (key args) in sequence
;;; and executes body of the first matching variant
(define-syntax case-variant
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((%_ (rename '_))
            (%<<< (rename '<<<))
            (%else (rename 'else))
            (%message? (rename 'message?))
            (%bind-case (rename 'bind-case))
            (type (cadr form))
            (xpr (caddr form))
            (variants (reverse (cdddr form))) ; to check for %else
            )
        (let ((type-key (symbol->keyword type))
              (default (if (compare? (caar variants) %else)
                         (car variants)
                         '()))
              (variants (if (compare? (caar variants) %else)
                          (reverse (cdr variants))
                          (reverse variants))))
          (let ((variant-keys (map car variants))
                (variant-args (map cadr variants))
                (variant-bodies (map cddr variants))
                (default-body (if (null? default)
                                '()
                                (cdr default))))
`(,%bind-case (,%<<< ,type-key ,xpr ,%message?)
   ,@(map (lambda (k a bs)
            `((,type-key ,k ,a) ,@bs))
          variant-keys variant-args variant-bodies)
   ,@(if (null? default)
       '()
       `((,%_ ,@default-body))))))))))



;;; (define-algebraic-type Child Parent ..
;;;   (variant-key (a a? ...) ...)
;;;   | (variant-key (a a? ...) ... as as? ...)
;;;   ....)
;;; -------------------------------------------
;;; defines a selector routine, Child, which, when called with the #:?
;;; keyword returns the type predicate, when called with another
;;; keyword, returns the corresponding message-constructor.
;;; When Child is called with no argument, it returns information on the
;;; type.
;;; Note that rest arguments, as, as well as their checks
;;; are not parenthesized. 
(define-syntax define-algebraic-type
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((Child (cadr form))
            (Parent (if (symbol? (caddr form))
                      (caddr form)
                      #f))
            (variants (if (symbol? (caddr form))
                        (cdddr form)
                        (cddr form)))
            (%or (rename 'or))
            (%<<< (rename '<<<))
            (%and (rename 'and))
            (%xpr (rename 'xpr))
            (%key (rename 'key))
            (%case (rename 'case))
            (%else (rename 'else))
            (%error (rename 'error))
            (%begin (rename 'begin))
            (%define (rename 'define))
            (%lambda (rename 'lambda))
            (%case-lambda (rename 'case-lambda))
            (%message? (rename 'message?))
            (%list-of? (rename 'list-of?))
            (%make-message (rename 'make-message))
            (%message-of? (rename 'message-of?))

            (%define-syntax (rename 'define-syntax))
            (%syntax-rules (rename 'syntax-rules))
            (%bind-case (rename 'bind-case))
            (%msg (rename 'msg))
            (%variant-key (rename 'variant-key))
            (%field-name (rename 'field-name))
            (%xpr0 (rename 'xpr0))
            (%xpr1 (rename 'xpr1))
            (%xprs0 (rename 'xprs0))
            (%xprs1 (rename 'xprs1))
            )
        (let ((kChild (symbol->keyword Child))
              (keys (map car variants))
              (xargs (map cdr variants))
              (dissect
                (lambda (key args)
                  (receive (fas vas)
                           (split-with symbol? args)
                    (values
                      (map car fas)
                      (if (null? vas) vas (car vas))
                      (map (lambda (f)
                             `(,%<<< '(,Child ,key) ,@f))
                           fas)
                      (if (null? vas)
                        vas
                        `(,%<<< '(,Child ,key)
                          ,(car vas)
                          ,@(map (lambda (v)
                                   `(,%list-of? ,v))
                                 (cdr vas))))))))
             )
`(,%begin
   (,%define ,Child
      (,%case-lambda
        (()
         ',(append
             `(,kChild)
             variants
             (if Parent
               ((eval Parent))
               '())))
        ((,%key)
         (,%case ,%key
           ((#:?)
            (,%lambda (,%xpr)
              (,%and (,%message? ,%xpr)
                     (,%or ((,%message-of? ,(symbol->keyword Child))
                            ,%xpr)
                           ,(if Parent
                              `((,Parent #:?) ,%xpr)
                              #f)))))
           ,@(map (lambda (key args)
                    (receive (fa va fchecks vcheck)
                      (dissect key args)
                      `((,key)
                        (,%lambda ,(append fa va)
                           (,%make-message
                             ,(symbol->keyword Child)  ;;;;
                             ,key
                             ,@fchecks
                             ,@(if (null? va)
                                 va
                                 (list vcheck)))))))
                  keys xargs)
           (,%else
             ,(if Parent
                `(,Parent ,%key)
                `(,%error ',Child "wrong key" ,%key)))))
        ))
     ))))))

;;; (define-abstract-type Child Parent ..
;;;   (variant-key (a a? ...) ...)
;;;   | (variant-key (a a? ...) ... as as? ...)
;;;    ....
;;;   (with
;;;     ((key (x x? ...) ...)
;;;      | (key (x x? ...) ... xs xs? ...))
;;;      xpr ....)
;;;     ....)))
;;; ---------------------------------------------------------------
;;; defines a hidden algebraic type with keys variant-key ...,
;;; and exports a selector routine, Child, which, when called with the
;;; #:? keyword, returns the type predicate, when called with another
;;; keyword, returns the corresponding routine and when called without
;;; argument, returns information on the abstract type.
;;; Note that the exported objects in the with clause have access to the
;;; hidden algebraic type, which can be processed via Child-case
(define-syntax define-abstract-type
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((Child (cadr form))
            (Parent (if (symbol? (caddr form))
                      (caddr form)
                      #f))
            (rest (if (symbol? (caddr form))
                    (cdddr form)
                    (cddr form)))
            (%with (rename 'with))
            )
        (receive (variants routines)
          (let loop ((rest rest) (variants '()))
            (cond
              ((compare? (caar rest) %with)
               (values (reverse variants) (cdar rest)))
              ((null? rest)
               (error 'define-abstract-type "no with clause"))
              (else
                (loop (cdr rest) (cons (car rest) variants)))))
          (let ((keys (map car variants))
                (headers (map car routines))
                (bodies (map cdr routines))
                (kChild (symbol->keyword Child))
                (AChild (symbol-append 'A Child))
                (AParent (if Parent (symbol-append 'A Parent) #f))
                (%map (rename 'map))
                (%<<< (rename '<<<))
                (%let (rename 'let))
                (%xpr (rename 'xpr))
                (%set! (rename 'set!))
                (%case (rename 'case))
                (%name (rename 'name))
                (%else (rename 'else))
                (%error (rename 'error))
                (%begin (rename 'begin))
                (%values (rename 'values))
                (%letrec (rename 'letrec))
                (%lambda (rename 'lambda))
                (%define (rename 'define))
                (%list-of? (rename 'list-of?))
                (%case-lambda (rename 'case-lambda))
                (%define-values (rename 'define-values))
                (%define-algebraic-type (rename 'define-algebraic-type))
                )
            (let ((names (map car headers))
                  (xargs (map cdr headers))
                  (dissect
                    (lambda (key args)
                      (receive (fas vas)
                               ;(split args)
                               ;(split-at args (list-index symbol? args))
                               (split-with symbol? args)
                        (values
                          (map car fas)
                          (if (null? vas) vas (car vas))
                          (map (lambda (f)
                                 `(,%<<< '(,Child ,key) ,@f))
                               fas)
                          (if (null? vas)
                            vas
                            `(,%<<< '(,Child ,key)
                              ,(car vas)
                              ,@(map (lambda (v)
                                       `(,%list-of? ,v))
                                     (cdr vas))))))))
              )
`(,%define ,Child
   (,%let ((,AChild #f))
   ;(,%letrec ((,AChild #f))
     ,(if Parent
        `(,%define-algebraic-type ,Child ,Parent ,@variants)
        `(,%define-algebraic-type ,Child ,@variants))
     (,%set! ,AChild
       (,%case-lambda
         (() (,Child))
         ((,%name)
          (,%case ,%name
             ((#:?) (,Child #:?))
             ,@(map (lambda (key args body)
                      (receive (fa va fchecks vcheck)
                        (dissect key args)
                        `((,key)
                          (,%lambda ,(append fa va)
                             (,%let ,(map (lambda (i c)
                                            `(,i ,c))
                                          fa fchecks)
                                (,%let ,(if (null? va)
                                          va
                                          `((,va ,vcheck)))
                                  ,@body))))))
                    names xargs bodies)
            (,%else
              ,(if Parent
                   `(,Parent ,%name)
                   `(,%error ',Child 
                      "invalid name"
                      ,%name)))))))
     ,AChild))
     )))))))

;;; (define-object-type Child Parent ..
;;;   (state ((a a? ...) ....) | ((a a? ...) ... as as?  ...)
;;;     inv ...)
;;;   ;; message constructors paired with code
;;;   ((#:x (x x? ...) ...)
;;;    | (#:x (x x? ...) ... xs xs? ...))
;;;    xpr ....)
;;;   ....))
;;; -------------------------------------------------
;;; where a, ... as ... are the instance variables, checked by
;;; a? .... and as? ... respectively, and inv ...
;;; is the body of the invariant
(define-syntax define-object-type
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((Child (cadr form))
            (Parent (if (symbol? (caddr form))
                      (caddr form)
                      #f))
            (body (if (symbol? (caddr form))
                    (cdddr form) ;(cadddr form)
                    (cddr form)));(caddr form)))
            (split
              (lambda (xargs)
                (let loop ((tail xargs) (head '()))
                  (cond
                    ((null? tail)
                     (values (reverse head) tail))
                    ((symbol? (car tail))
                     (values (reverse head) tail))
                    (else
                      (loop (cdr tail) (cons (car tail) head)))))))
            (%state (rename 'state)))
        (if (compare? (caar body) %state)
          (let ((Child-instance (symbol-append Child '-instance))
                (state (car body))
                (messages (cdr body))
                (car* (lambda (l)
                        ;(if (null? l) l (car l))))
                        (if (pair? l) (car l) l)))
                (%or (rename 'or))
                (%if (rename 'if))
                (%=> (rename '=>))
                (%var (rename 'var))
                (%car (rename 'car))
                (%cdr (rename 'cdr))
                (%msg (rename 'msg))
                (%xpr (rename 'xpr))
                (%key (rename 'key))
                (%eq? (rename 'eq?))
                (%exn (rename 'exn))
                (%and (rename 'and))
                (%<<< (rename '<<<))
                (%let (rename 'let))
                (%list (rename 'list))
                (%cadr (rename 'cadr))
                (%cons (rename 'cons))
                (%else (rename 'else))
                (%case (rename 'case))
                (%self (rename 'self))
                (%memq (rename 'memq))
                (%null? (rename 'null?))
                (%arity (rename 'arity))
                (%error (rename 'error))
                (%begin (rename 'begin))
                (%list? (rename 'list?))
                (%pair? (rename 'pair?))
                (%state (rename 'state))
                (%apply (rename 'apply))
                (%append (rename 'append))
                (%result (rename 'result))
                (%lambda (rename 'lambda))
                (%values (rename 'values))
                (%define (rename 'define))
                (%receive (rename 'receive))
                (%message? (rename 'message?))
                (%list-of? (rename 'list-of?))
                (%invariant? (rename 'invariant?))
                (%procedure? (rename 'procedure?))
                (%message-of? (rename 'message-of?))
                (%condition-case (rename 'condition-case))
                (%case-lambda (rename 'case-lambda))
                (%case-variant (rename 'case-variant))
                (%define-algebraic-type (rename 'define-algebraic-type))
                )
                (receive (fstate vstate) (split (cadr state)) ;state)
                  (let ((kChild-instance (symbol->keyword
                                           Child-instance))
                        (inv (cddr state))
                        (super (if Parent (caaadr state) #f))
                        (keys (map caar messages))
                        (fms (map (lambda (m)
                                    ;(print "MMM " m " AAA " (cdar m))
                                    (split (cdar m)))
                                  messages))
                        (vms (map (lambda (m)
                                    (nth-value 1 (split (cdar m))))
                                  messages))
                        (bodies (map cdr messages))
                        (kChild (symbol->keyword Child))
                        (fargs (map car* fstate))
                        (varg (if (null? vstate) `(,%list) (car vstate))));(car* vstate)))
                  ;(print "III " fargs) 
                  ;(print "JJJ " varg)
                  ;(print "VVV " vstate)
                  ;(print "vvv " vms " lll " (length vms))
                  ;(print "fff " fms " lll " (length fms))
                  ;(print "kkk " keys " lll " (length keys))
                  ;(print "XXX " (map append fms vms))
                    (let ((iargs (append fargs (car* vstate)))
                          (some-handlers
                            (map (lambda (k x b)
                                   `(,k ,(map car* x) ,@b))
                                 keys
                                 (map append fms vms)
                                 bodies))
                          (some-args
                            (cond
                              ((null? vstate)
                               (map (lambda (s)
                                      `(,(car s)
                                         (,%<<< ,kChild-instance
                                                ,(car s)
                                                ,@(cdr s))))
                                    fstate))
                              ((null? fstate)
                               `((,(car vstate)
                                   (,%<<< ,kChild-instance
                                          ,(car vstate)
                                          (,%list-of?  ,@(cdr vstate))))))
                              (else
                                (append
                                  (map (lambda (s)
                                         `(,(car s)
                                            (,%<<< ,kChild-instance
                                                   ,(car s)
                                                   ,@(cdr s))))
                                     fstate)
                                  `((,(car vstate)
                                      (,%<<< ,kChild-instance
                                             ,(car vstate)
                                             (,%list-of?
                                               ,@(cdr vstate))))))))))
                      ;(print "some-args " some-args)

`(,%begin
   (,%define-algebraic-type ,Child
     ,@(if Parent
         (cons Parent
               (cons '(#:invariant?)
                     (map car messages)))
         (cons '(#:invariant?) (map car messages))))
   (,%define (,Child-instance ,@iargs)
     (,%let (,@some-args
             (,%invariant? (,%lambda ,iargs
                             ,@(cddr state))))
      (,%if (,%apply ,%invariant? ,@fargs ,varg)
        (,%case-lambda
          (()
           (,%append 
             ',(cons kChild-instance (cdr state))
             (,%if ,Parent (,super) '())))
          ((,%msg)
           ,(if Parent
              `(,%if ((,Parent #:?) ,%msg)
                 (,super ,%msg)
                 (,%case-variant ,Child ,%msg
                   (#:invariant? ()
                     (,%apply ,%invariant? ,@fargs ,varg))
                   ,@some-handlers
                   ))
              `(,%case-variant ,Child ,%msg
                 (#:invariant? ()
                   (,%apply ,%invariant? ,@fargs ,varg))
                 ,@some-handlers
                 (,%else (,%error ',Child
                                  "not a valid message"
                                  ,%msg))))))
        (,%error ',Child-instance "invariant violated"))))
   (,%define (,(symbol-append Child-instance '?) ,%xpr)
     (,%if (,%procedure? ,%xpr)
           (,%let ((,%result (,%condition-case (,%xpr)
                                               ((,%exn ,%arity) #f))))
              (,%and ,%result
                     (,%if (,%memq ,kChild-instance ,%result)
                           #t #f)))
           #f))
   )
   )))))))))

(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (error "Not in list"
                sym
                (map car alist)))))))

;;; (messages sym ..)
;;; ------------------
;;; documentation procedure
(define messages
  (symbol-dispatcher '(
    (messages
      procedure:
      (messages sym ..)
      "documentation procedure")
    (case-variant
      macro:
      "(case-variant type msg"
      "  (variant-key (arg ...) xpr ....)"
      "  ..."
      "  (else xpr ....) ..)"
      "destructures msg of type depending on its variants"
      "by means of pattern-matching against (variant-key (arg ...))"
      "and executes the corresponding body xpr ....")
    (define-algebraic-type
      macro:
      "(define-algebraic-type Child Parent .."
      "   (variant-key (a a? ...) ...)"
      "   | (variant-key (a a? ...) ... as as? ...)"
      "   ....)"
      "defines a selector routine, Child, which, when called with the"
      "#:? keyword returns the type predicate, when called with another"
      "keyword, returns the corresponding message-constructor."
      "When Child is called with no argument, it returns information"
      "on the type.")
    (define-abstract-type
      macro:
      "(define-abstract-type Child Parent .."
      "  (variant-key (a a? ...) ...)"
      "  | (variant-key (a a? ...) ... as as? ...)"
      "   ...."
      "  (with"
      "    ((key (x x? ...) ...)"
      "     | (key (x x? ...) ... xs xs? ...))"
      "     xpr ....)"
      "    ....))"
      "defines a hidden algebraic type with keys variant-key ...,"
      "and exports a selector routine, Child, which, when called with"
      "the #:? keyword, returns the type predicate, when called with"
      "another keyword, returns the corresponding routine and when"
      "called without argument, returns information on the abstract type."
      "Note that the exported objects in the with clause have access to"
      "the hidden algebraic type, which can be processed by"
      "case-variant.")
    (define-object-type
      macro:
      "(define-object-type Child Parent .."
      "  (state ((a a? ...) ....) | ((a a? ...) ...  as as? ...)"
      "    inv ...)"
      "  ((#:x (x x? ...) ...)"
      "     | (#:x (x x? ...) ... xs xs? ...))"
      "     xpr ....)"
      "    ....))"
      "where a, ... as ... are the instance variables, checked by"
      "a? .... and as? ... respectively, and inv ... is the body"
      "of the invariant."
      "Defines a constructor (Child-instance a ... [. as]),"
      "checked with predicate Child-instance?,"
      "as well as an algebraic-type Child, which is used to"
      "manipulate the instance's state")
    (make-message
      procedure:
      (make-message type-key key . args)
      "type constructor")
    (message?
      procedure:
      (message? xpr)
      "type predicate")
    (message-type
      procedure:
      (message-type msg)
      "type accessor: returns type key")
    (message-key
      procedure:
      (message-key msg)
      "type accessor: returns instance key")
    (message-data
      procedure:
      (message-data msg)
      "type accessor: returns data vector")
    (message-of?
      procedure:
      (message-of? type-key)
      "returns a predicate which checks,"
      "if its argument is a message of type-key")
    (split-with
      procedure:
      (split-with where? lst)
      "returns two values by splitting a list, lst,"
      "at predicate where?"
      "exported since defined with syntax")
    )))

  ) ; module messages

;(import messages
;        simple-tests
;        simple-cells
;        checks
;        symbol-name-utils
;        bindings)
;
;(pe '
;  (define-object-type Bar
;    (state (as number?) #t)
;    ((#:xs xs number?) xs))
;  )
;
;(define-object-type Bar
;  (state (as number?) #t)
;  ((#:xs) as))
;
;(define bar (Bar-instance 1 2 3))
;
;(ppp (Bar-instance? bar)
;     (Bar-instance)
;     (Bar)
;     (bar)
;     bar
;     (bar ((Bar #:xs)))
;     (bar ((Bar #:invariant?)))
;     )
;
;(pe '
;  (define-object-type Baz
;    (state ((a number?) as number?) #t)
;    ((#:x) a)
;    ((#:xs) as))
;  )
;
;(define-object-type Baz
;  (state ((a number?) as number?) #t)
;  ((#:x) a)
;  ((#:xs) as))
;
;(define baz (Baz-instance 0 1 2 3))
;
;(ppp (Baz-instance? baz)
;     (baz)
;     (baz ((Baz #:xs)))
;     (baz ((Baz #:x)))
;     (baz ((Baz #:invariant?)))
;     )
;
;;;(pe '(case-variant Option opt
;;;;       (#:none () #f)
;;;;       (#:some (a) a)))
;;;;
;;;;(pe '(case-variant Option opt
;;;;       (#:some (a) a)
;;;;       (else #f)))
;;;;
;;;;;; options as algebraic types
;;;;(print "\noptions as algebraic types")
;;;;(print "--------------------------\n")
;;;;(define-algebraic-type Option
;;;;  (#:none)
;;;;  (#:some (arg))) ; arg not typed
;;;;
;;;;(define (bar opt)
;;;;  (case-variant Option opt
;;;;    (#:some (arg) arg)
;;;;    (else #f)))
;;;;
;;;;(define (baz opt)
;;;;  (case-variant Option opt
;;;;    (#:none () #f)
;;;;    (#:some (arg) arg)))
;;;;
;;;;(ppp ((Option #:?) ((Option #:none)))
;;;;     ((Option #:?) ((Option #:some) 5))
;;;;     (Option)
;;;;     (bar ((Option #:none)))
;;;;     (bar ((Option #:some) 5))
;;;;     bar
;;;;     (baz ((Option #:none)))
;;;;     (baz ((Option #:some) 5))
;;;;     baz
;;;;     )
;;;;
;;(pe '
;;  (define-algebraic-type Single
;;    (#:maker (x number?))
;;    )
;;  )
;;
;;  (define-algebraic-type Single
;;    (#:maker (x number?))
;;    )
;;
;;(pe '
;;  (define-algebraic-type Couple Single
;;    (#:maker (parent (Single #:?)) (y number?))
;;    )
;;  )
;;
;;  (define-algebraic-type Couple Single
;;    (#:maker (parent (Single #:?)) (y number?))
;;    )
;
;;(pe '
;;  (define-object-type Rect
;;    (state ((x% (cell-of? number?))
;;            (y% (cell-of? number?))
;;            (w% (cell-of? number?))
;;            (h% (cell-of? number?)))
;;      #t)
;;    ((#:x) (x%))
;;    ((#:y) (y%))
;;    ((#:w) (w%))
;;    ((#:h) (h%))
;;    ((#:x! (x number?)) (x% x))
;;    ((#:y! (y number?)) (y% y))
;;    ((#:w! (w number?)) (w% w))
;;    ((#:h! (h number?)) (h% h))
;;    ((#:move! (dx number?) (dy number?))
;;     ;(x% (+ dx (#:x%)))
;;     ;(y% (+ dy (#:y%))))
;;     (let ((x (x%)) (y (y%)))
;;       (x% (+ dx x)) 
;;       (y% (+ dy y))
;;       (list x y)))
;;    ((#:scale! (r number?))
;;     ;(w% (* r (#:w%)))
;;     ;(h% (* r (#:h%))))
;;     (let ((w (w%)) (h (h%)))
;;       (w% (* r w))
;;       (h% (* r h))
;;       (list w h)))
;;    )
;;  )
;
;  (define-object-type Rect
;    (state ((x% (cell-of? number?))
;            (y% (cell-of? number?))
;            (w% (cell-of? number?))
;            (h% (cell-of? number?)))
;      #t)
;    ((#:x) (x%))
;    ((#:y) (y%))
;    ((#:w) (w%))
;    ((#:h) (h%))
;    ((#:x! (x number?)) (x% x))
;    ((#:y! (y number?)) (y% y))
;    ((#:w! (w number?)) (w% w))
;    ((#:h! (h number?)) (h% h))
;    ((#:move! (dx number?) (dy number?))
;     ;(x% (+ dx (#:x%)))
;     ;(y% (+ dy (#:y%))))
;     (let ((x (x%)) (y (y%)))
;       (x% (+ dx x)) 
;       (y% (+ dy y))
;       (list x y)))
;    ((#:scale! (r number?))
;     ;(w% (* r (#:w%)))
;     ;(h% (* r (#:h%))))
;     (let ((w (w%)) (h (h%)))
;       (w% (* r w))
;       (h% (* r h))
;       (list w h)))
;    )
;(define rect (Rect-instance (cell 0) (cell 0) (cell 1) (cell 1)))
;
;(ppp rect
;     (rect)
;     (Rect-instance? rect)
;     Rect
;     (Rect)
;     (Rect #:x)
;     ((Rect #:x))
;     (rect ((Rect #:x)))
;     (rect ((Rect #:x!) 10))
;     (rect ((Rect #:x)))
;     (rect ((Rect #:invariant?)))
;     (rect ((Rect #:move!) 100 100))
;     (rect ((Rect #:x)))
;     (rect ((Rect #:y)))
;     (rect ((Rect #:scale!) 100))
;     (rect ((Rect #:w)))
;     (rect ((Rect #:h)))
;     )
;
;;;(pe '
;;;;  (define-object-type Square Rect
;;;;    (state ((parent Rect-instance?))
;;;;      (= (parent ((Rect #:w))) (parent ((Rect #:h)))))
;;;;    ((#:parent) parent)
;;;;    ((#:w! (w number?))
;;;;     ;(let ((old (parent ((Rect #:w)))))
;;;;       (parent ((Rect #:w!) w))
;;;;       (parent ((Rect #:h!) w))
;;;;     ;  old))
;;;;     )
;;;;    ((#:h! (h number?))
;;;;     ;(let ((old (parent ((Rect #:h)))))
;;;;       (parent ((Rect #:w!) h))
;;;;       (parent ((Rect #:h!) h))
;;;;     ;  old))
;;;;     )
;;;;    ((#:scale! (r number?))
;;;;     ;(let ((old-w (parent ((Rect #:w))))
;;;;     ;      (old-h (parent ((Rect #:h)))))
;;;;       (parent ((Rect #:scale!) r)))
;;;;    ))
;;;
;;;;(ppp square
;;;;     rect
;;;;     (square)
;;;;     (rect)
;;;;     (Rect-instance? rect)
;;;;     (Square-instance? square)
;;;;     (Rect-instance? square)
;;;;     (Square-instance? rect)
;;;;     (square ((Square #:invariant?)))
;;;;     (square ((Square #:w!) 5))
;;;;     (square ((Square #:w)))
;;;;     (square ((Square #:h)))
;;;;     (square ((Square #:scale!) 10))
;;;;     (square ((Square #:w)))
;;;;     (square ((Square #:h)))
;;;;     (square ((Square #:x)))
;;;;     (square ((Square #:y)))
;;;;     (square ((Square #:move!) 2 2))
;;;;     (square ((Square #:x)))
;;;;     (square ((Square #:y)))
;;;;     (Rect)
;;;;     (Square)
;;;;     (Rect-instance? (square ((Square #:parent))))
;;;;     ((Rect #:?) ((Square #:x)))     ; #t: x not overridden
;;;;     ((Rect #:?) ((Square #:x!) 5))  ; #t: x! not overridden
;;;;     ((Rect #:?) ((Square #:w)))     ; #t: w not overridden
;;;;     ((Rect #:?) ((Square #:w!) 5))  ; #f: w! overridden
;;;;     (rect ((Square #:x)))           ; #t: x not overridden
;;;;     (rect ((Rect #:x)))
;;;;     (square ((Square #:invariant?)))
;;;;     )
;;;