(import messages checks simple-cells simple-tests)

;(bind-listify* vector? vector-car vector-cdr)

(print "\nmessages")
(print "--------")

(define msg (make-message #:Type #:foo 0 1 2))

(define-test (messages?)
  (message? msg)
  (not (message? #(0 1 2)))
  ((message-of? #:Type) msg)
  (not ((message-of? #:Bar) msg))
  (eq? (message-type msg) #:Type)
  (eq? (message-key msg) #:foo)
  (equal? (message-data msg) #(0 1 2))
  )

(messages?)

(print "\nvariable arguments")
(print "------------------")

(define-algebraic-type Foo
  (#:make (x number?) xs number?)
  )

(define foo ((Foo #:make) 0 1 2 3))

(define-test (vargs?)
  ((Foo #:?) foo)
  (zero? (case-variant Foo foo
           (#:make (x xs) x)
           (else #f)))
  (equal? (case-variant Foo foo
            (#:make (x xs) xs)
            (else #f))
          '(1 2 3))
  )

(vargs?)

(print "\noptions")
(print "-------")

(define-algebraic-type Option
  (#:none)
  (#:some (arg)))

(define (qux opt)
  (case-variant Option opt
    (#:none () #f)
    (#:some (arg) arg)))
;(pe '(case-variant Option ((Option #:none))
;                   (#:none () #f)
;                   (#:some (arg) arg)))
(define-test (options?)
  (not (case-variant Option ((Option #:none))
         (#:none () #f)
         (#:some (arg) arg)))
  (= (case-variant Option ((Option #:some) 5)
       (#:none () #f)
       (#:some (arg) arg)) 5)
  (not (case-variant Option ((Option #:some) #f)
         (#:none () #f)
         (#:some (arg) arg)))
  ((Option #:?) ((Option #:none)))
  ((Option #:?) ((Option #:some) 5))
  (= (qux ((Option #:some) 5)) 5)
)

(options?)
;
(print "\nSlists")
(print "------")

(define-algebraic-type Slist
  (#:null)
  (#:cons (front (Sexpr #:?))
          (rest  (Slist #:?))))

(define-algebraic-type Sexpr
  (#:sym  (data symbol?))
  (#:list (data (Slist #:?))))

(define Slist-in
  (letrec (
    (in-sx (lambda (sx)
             (if (symbol? sx)
               ((Sexpr #:sym) sx)
               ((Sexpr #:list)
                (in-sl sx)))))
    (in-sl (lambda (sl)
             (cond
               ((null? sl)
                ((Slist #:null)))
               ((symbol? sl)
                ((Sexpr #:sym) sl))
               (else
                 ((Slist #:cons)
                  (in-sx (car sl))
                  (in-sl (cdr sl)))))))
    )
    in-sl))

(define (Slist-out ss)
  (letrec (
    (out-sx (lambda (sx)
              (case-variant Sexpr sx
                (#:sym (data)
                 data)
                (#:list (data)
                 (out-sl data)))))
    (out-sl (lambda (sl)
              (case-variant Slist sl
                (#:null ()
                 '())
                (#:cons (front rest)
                  (cons (out-sx front)
                        (out-sl rest))))))
    )
    (if ((Sexpr #:?) ss)
      (out-sx ss)
      (out-sl ss))))

(define (Slist-subst new old ss)
  (letrec (
    (subst-sx (lambda (sx)
                (case-variant Sexpr sx
                  (#:sym (data)
                   (if (eq? data old)
                     ((Sexpr #:sym) new)
                     ((Sexpr #:sym) data)))
                     ;sx))
                  (#:list (data) ;else
                    ((Sexpr #:list) 
                     (subst-sl data))))))
    (subst-sl (lambda (sl)
                (case-variant Slist sl
                  (#:null ()
                    ((Slist #:null)))
                   (#:cons (front rest)
                    ((Slist #:cons)
                      (subst-sx front)
                      (subst-sl rest))))))
    )
    (if ((Sexpr #:?) ss)
      (subst-sx ss)
      (subst-sl ss))))

(define sl (Slist-in '()))
(define sx (Slist-in 'old))
(define sxl (Slist-in '(old)))
(define sxx (Slist-in '(())))
(define sll (Slist-in '((old c) (old () d))))
(define xxx (Slist-in '(old ((old) ((old x)) y))))

(define-test (slists?)
  ((Slist #:?) sl)
  ((Slist #:?) (Slist-subst 'new 'old sl))
  ((Sexpr #:?) sx)
  ((Sexpr #:?) (Slist-subst 'new 'old sx))
  ((Slist #:?) sxl)
  ((Slist #:?) (Slist-subst 'new 'old sxl))
  ((Slist #:?) sxx)
  ((Slist #:?) (Slist-subst 'new 'old sxx))
  ((Slist #:?) sll)
  ((Slist #:?) (Slist-subst 'new 'old sll))
  ((Slist #:?) xxx)
  ((Slist #:?) (Slist-subst 'new 'old xxx))
  (null? (Slist-out sl))
  (null? (Slist-out (Slist-subst 'new 'old sl)))
  (eq? (Slist-out sx) 'old)
  (eq? (Slist-out (Slist-subst 'new 'old sx)) 'new)
  (equal? (Slist-out sxl) '(old))                         
  (equal? (Slist-out (Slist-subst 'new 'old sxl)) '(new))
  (equal? (Slist-out sxx) '(()))
  (equal? (Slist-out (Slist-subst 'new 'old sxx)) '(()))
  (equal? (Slist-out sll) '((old c) (old () d)))                       
  (equal? (Slist-out (Slist-subst 'new 'old sll)) '((new c) (new () d)))
  (equal? (Slist-out xxx) '(old ((old) ((old x)) y)))
  (equal? (Slist-out (Slist-subst 'new 'old xxx)) '(new ((new) ((new x)) y)))
  )

(slists?)

(print "\nTuples")
(print "------")

(define-algebraic-type Single
  (#:maker (x number?))
  )

(define sgl ((Single #:maker) 1))

(define-algebraic-type Couple Single
  (#:maker (parent (Single #:?)) (y number?))
  )

(define cpl ((Couple #:maker)
             ((Single #:maker) 1)
             2))

(define-algebraic-type Triple Couple
  (#:maker (parent (Couple #:?)) (z number?))
  )

(define trp ((Triple #:maker)
             ((Couple #:maker)
              ((Single #:maker) 1)
              2)
             3))

(define-test (tuples?)
  ((Triple #:?) trp)
  (not ((Couple #:?) trp))
  (not ((Single #:?) trp))
  ((Couple #:?) sgl)
  ((Triple #:?) sgl)
  ((Triple #:?) cpl)
  (= 1
     (let* ((cpl ;(case-variant Triple trp
                 (Triple-case trp
                   (#:maker (parent z) parent)))
            (sgl ;(case-variant Couple cpl
                 (Couple-case cpl
                   (#:maker (parent y) parent))))
       ;(case-variant Single sgl
       (Single-case sgl
         (#:maker (x) x))))
  (= 2
     (let ((cpl ;(case-variant Triple trp
                (Triple-case trp
                  (#:maker (parent z) parent))))
       ;(case-variant Couple cpl
       (Couple-case cpl
         (#:maker (parent y) y))))
  (= 3
     ;(case-variant Triple trp
     (Triple-case trp
       (#:maker (parent z) z)))
  )

(tuples?)

(print "\nimmutable typed lists as abstract types")
(print "---------------------------------------")

(define (0<= x) (and (number? x) (not (negative? x))))
(define-abstract-type List
  (#:null)
  (#:cons (first number?) (rest (List #:?)))
  (with
    ((#:maker args number?)
     (let loop ((args args))
       (if (null? args)
         ((List #:null))
         ((List #:cons) (car args)
                        (loop (cdr args))))))
    ((#:null? (xs (List #:?)))
     (case-variant List xs
       (#:null () #t)
       (else #f)))
    ((#:ref (xs (List #:?))
            (k 0<=))
     (let loop ((xs xs) (k k))
       (case-variant List xs
         (#:null () (error '(List #:ref)))
         (#:cons (a as) (if (zero? k)
                          a
                          (loop as (- k 1)))))))
    ((#:tail (xs (List #:?))
             (k 0<=))
     (let loop ((xs xs) (k k))
       (case-variant List xs
         (#:null () xs)
         (#:cons (a as) (if (zero? k)
                          xs
                          (loop as (- k 1)))))))
    ))

(define as0123 ((List #:maker) 0 1 2 3)) 

(define-test (abstract-lists?)
  ((List #:?) as0123)
  (not ((List #:?) '(a b c)))
  (not ((List #:null?) as0123))
  ((List #:null?) ((List #:maker)))
  (= 2 ((List #:ref) as0123 2))
  (= 2 ((List #:ref) ((List #:tail) as0123 2) 0))
  ((List #:null?) ((List #:tail) as0123 4))
  (not (condition-case ((List #:ref) as0123 5)
         ((exn) #f)))
  )

;(abstract-lists?)

(print "\nmutable points as abstract types")
(print "--------------------------------")

(define-abstract-type Point
  (#:maker (x (cell-of? number?)) (y (cell-of? number?))) ; hidden
  (with
    ((#:make (x (cell-of? number?)) (y (cell-of? number?))) ; exported
     ((Point #:maker) x y))
    ((#:x (pt (Point #:?)))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (x))))
    ((#:x! (pt (Point #:?)) (arg number?))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (x arg))))
    ((#:y (pt (Point #:?)))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (y))))
    ((#:y! (pt (Point #:?)) (arg number?))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (y arg))))
    ))

(define pt ((Point #:make) (cell 1) (cell 2)))

(define-test (mutable-points?)
  (not (condition-case ((Point #:maker) 10 20)
         ((exn) #f)))
  (= ((Point #:x) pt) 1)
  (= ((Point #:x!) pt 10) 1) ; old value
  (= ((Point #:x) pt) 10)
  (= ((Point #:y) pt) 2)
  (= ((Point #:y!) pt 20) 2) ; old value
  (= ((Point #:y) pt) 20)
  ((Point #:?) pt)
  (not ((Point #:?) 5))
  )

;(mutable-points?)


(compound-test (DATATYPES)
  (messages?)
  (vargs?)
  (options?)
  (slists?)
  (tuples?)
  (abstract-lists?)
  (mutable-points?)
  )

;(import functional-vectors messages simple-cells simple-tests checks)
;
;(print "\functional-vectors")
;(print "-----------------")
;
;(define fv0 (fvector 0 1 2))
;(define fv1 (fvector 0 1 (fvector 2 3)))
;
;(define-test (fvectors?)
;  (fvector? fv0)
;  (not (fvector? (vector 0 1 2)))
;  (fvector? fv1)
;  (not (fvector? (vector 0 1 (vector 2 3))))
;  (equal? (fvector-data fv0) '(0 1 2))
;  (equal? (fvector-data fv1) '(0 1 (2 3)))
;  )
;(fvectors?)
;
;(print "\nmessages")
;(print "--------")
;
;(define msg (make-message #:Type #:foo 0 1 2))
;
;(define-test (messages?)
;  (message? msg)
;  (not (message? #(0 1 2)))
;  ((message-of? #:Type) msg)
;  (not ((message-of? #:Bar) msg))
;  (eq? (message-type msg) #:Type)
;  (eq? (message-key msg) #:foo)
;  (equal? (message-data msg) #(0 1 2))
;  )
;
;(messages?)
;
;(print "\nvariable arguments")
;(print "------------------")
;
;(define-algebraic-type Foo
;  (#:make (x number?) xs number?)
;  )
;
;(define foo ((Foo #:make) 0 1 2 3))
;
;(define-test (vargs?)
;  ((Foo #:?) foo)
;  (zero? (case-variant Foo foo
;           (#:make (x xs) x)
;           (else #f)))
;  (equal? (case-variant Foo foo
;            (#:make (x xs) xs)
;            (else #f))
;          '(1 2 3))
;  )
;
;(vargs?)
;
;(print "\noptions")
;(print "-------")
;
;(define-algebraic-type Option
;  (#:none)
;  (#:some (arg)))
;
;(define (qux opt)
;  (case-variant Option opt
;    (#:none () #f)
;    (#:some (arg) arg)))
;;(pe '(case-variant Option ((Option #:none))
;;                   (#:none () #f)
;;                   (#:some (arg) arg)))
;(define-test (options?)
;  (not (case-variant Option ((Option #:none))
;         (#:none () #f)
;         (#:some (arg) arg)))
;  (= (case-variant Option ((Option #:some) 5)
;       (#:none () #f)
;       (#:some (arg) arg)) 5)
;  (not (case-variant Option ((Option #:some) #f)
;         (#:none () #f)
;         (#:some (arg) arg)))
;  ((Option #:?) ((Option #:none)))
;  ((Option #:?) ((Option #:some) 5))
;  (= (qux ((Option #:some) 5)) 5)
;)
;
;(options?)
;;
;(print "\nSlists")
;(print "------")
;
;(define-algebraic-type Slist
;  (#:null)
;  (#:cons (front (Sexpr #:?))
;          (rest  (Slist #:?))))
;
;(define-algebraic-type Sexpr
;  (#:sym  (data symbol?))
;  (#:list (data (Slist #:?))))
;
;(define Slist-in
;  (letrec (
;    (in-sx (lambda (sx)
;             (if (symbol? sx)
;               ((Sexpr #:sym) sx)
;               ((Sexpr #:list)
;                (in-sl sx)))))
;    (in-sl (lambda (sl)
;             (cond
;               ((null? sl)
;                ((Slist #:null)))
;               ((symbol? sl)
;                ((Sexpr #:sym) sl))
;               (else
;                 ((Slist #:cons)
;                  (in-sx (car sl))
;                  (in-sl (cdr sl)))))))
;    )
;    in-sl))
;
;(define (Slist-out ss)
;  (letrec (
;    (out-sx (lambda (sx)
;              (case-variant Sexpr sx
;                (#:sym (data)
;                 data)
;                (#:list (data)
;                 (out-sl data)))))
;    (out-sl (lambda (sl)
;              (case-variant Slist sl
;                (#:null ()
;                 '())
;                (#:cons (front rest)
;                  (cons (out-sx front)
;                        (out-sl rest))))))
;    )
;    (if ((Sexpr #:?) ss)
;      (out-sx ss)
;      (out-sl ss))))
;
;(define (Slist-subst new old ss)
;  (letrec (
;    (subst-sx (lambda (sx)
;                (case-variant Sexpr sx
;                  (#:sym (data)
;                   (if (eq? data old)
;                     ((Sexpr #:sym) new)
;                     ((Sexpr #:sym) data)))
;                     ;sx))
;                  (#:list (data) ;else
;                    ((Sexpr #:list) 
;                     (subst-sl data))))))
;    (subst-sl (lambda (sl)
;                (case-variant Slist sl
;                  (#:null ()
;                    ((Slist #:null)))
;                   (#:cons (front rest)
;                    ((Slist #:cons)
;                      (subst-sx front)
;                      (subst-sl rest))))))
;    )
;    (if ((Sexpr #:?) ss)
;      (subst-sx ss)
;      (subst-sl ss))))
;
;(define sl (Slist-in '()))
;(define sx (Slist-in 'old))
;(define sxl (Slist-in '(old)))
;(define sxx (Slist-in '(())))
;(define sll (Slist-in '((old c) (old () d))))
;(define xxx (Slist-in '(old ((old) ((old x)) y))))
;
;(define-test (slists?)
;  ((Slist #:?) sl)
;  ((Slist #:?) (Slist-subst 'new 'old sl))
;  ((Sexpr #:?) sx)
;  ((Sexpr #:?) (Slist-subst 'new 'old sx))
;  ((Slist #:?) sxl)
;  ((Slist #:?) (Slist-subst 'new 'old sxl))
;  ((Slist #:?) sxx)
;  ((Slist #:?) (Slist-subst 'new 'old sxx))
;  ((Slist #:?) sll)
;  ((Slist #:?) (Slist-subst 'new 'old sll))
;  ((Slist #:?) xxx)
;  ((Slist #:?) (Slist-subst 'new 'old xxx))
;  (null? (Slist-out sl))
;  (null? (Slist-out (Slist-subst 'new 'old sl)))
;  (eq? (Slist-out sx) 'old)
;  (eq? (Slist-out (Slist-subst 'new 'old sx)) 'new)
;  (equal? (Slist-out sxl) '(old))                         
;  (equal? (Slist-out (Slist-subst 'new 'old sxl)) '(new))
;  (equal? (Slist-out sxx) '(()))
;  (equal? (Slist-out (Slist-subst 'new 'old sxx)) '(()))
;  (equal? (Slist-out sll) '((old c) (old () d)))                       
;  (equal? (Slist-out (Slist-subst 'new 'old sll)) '((new c) (new () d)))
;  (equal? (Slist-out xxx) '(old ((old) ((old x)) y)))
;  (equal? (Slist-out (Slist-subst 'new 'old xxx)) '(new ((new) ((new x)) y)))
;  )
;
;(slists?)
;
;(print "\nTuples")
;(print "------")
;
;(define-algebraic-type Single
;  (#:maker (x number?))
;  )
;
;(define sgl ((Single #:maker) 1))
;
;(define-algebraic-type Couple Single
;  (#:maker (parent (Single #:?)) (y number?))
;  )
;
;(define cpl ((Couple #:maker)
;             ((Single #:maker) 1)
;             2))
;
;(define-algebraic-type Triple Couple
;  (#:maker (parent (Couple #:?)) (z number?))
;  )
;
;(define trp ((Triple #:maker)
;             ((Couple #:maker)
;              ((Single #:maker) 1)
;              2)
;             3))
;
;(define-test (tuples?)
;  ((Triple #:?) trp)
;  (not ((Couple #:?) trp))
;  (not ((Single #:?) trp))
;  ((Couple #:?) sgl)
;  ((Triple #:?) sgl)
;  ((Triple #:?) cpl)
;  (= 1
;     (let* ((cpl ;(case-variant Triple trp
;                 (Triple-case trp
;                   (#:maker (parent z) parent)))
;            (sgl ;(case-variant Couple cpl
;                 (Couple-case cpl
;                   (#:maker (parent y) parent))))
;       ;(case-variant Single sgl
;       (Single-case sgl
;         (#:maker (x) x))))
;  (= 2
;     (let ((cpl ;(case-variant Triple trp
;                (Triple-case trp
;                  (#:maker (parent z) parent))))
;       ;(case-variant Couple cpl
;       (Couple-case cpl
;         (#:maker (parent y) y))))
;  (= 3
;     ;(case-variant Triple trp
;     (Triple-case trp
;       (#:maker (parent z) z)))
;  )
;
;(tuples?)
;
;(print "\nimmutable typed lists as abstract types")
;(print "---------------------------------------")
;
;(define (0<= x) (and (number? x) (not (negative? x))))
;(define-abstract-type List
;  (#:null)
;  (#:cons (first number?) (rest (List #:?)))
;  (with
;    ((#:maker args number?)
;     (let loop ((args args))
;       (if (null? args)
;         ((List #:null))
;         ((List #:cons) (car args)
;                        (loop (cdr args))))))
;    ((#:null? (xs (List #:?)))
;     (case-variant List xs
;       (#:null () #t)
;       (else #f)))
;    ((#:ref (xs (List #:?))
;            (k 0<=))
;     (let loop ((xs xs) (k k))
;       (case-variant List xs
;         (#:null () (error '(List #:ref)))
;         (#:cons (a as) (if (zero? k)
;                          a
;                          (loop as (- k 1)))))))
;    ((#:tail (xs (List #:?))
;             (k 0<=))
;     (let loop ((xs xs) (k k))
;       (case-variant List xs
;         (#:null () xs)
;         (#:cons (a as) (if (zero? k)
;                          xs
;                          (loop as (- k 1)))))))
;    ))
;
;(define as0123 ((List #:maker) 0 1 2 3)) 
;
;(define-test (abstract-lists?)
;  ((List #:?) as0123)
;  (not ((List #:?) '(a b c)))
;  (not ((List #:null?) as0123))
;  ((List #:null?) ((List #:maker)))
;  (= 2 ((List #:ref) as0123 2))
;  (= 2 ((List #:ref) ((List #:tail) as0123 2) 0))
;  ((List #:null?) ((List #:tail) as0123 4))
;  (not (condition-case ((List #:ref) as0123 5)
;         ((exn) #f)))
;  )
;
;(abstract-lists?)
;
;(print "\nmutable points as abstract types")
;(print "--------------------------------")
;
;(define-abstract-type Point
;  (#:maker (x (cell-of? number?)) (y (cell-of? number?))) ; hidden
;  (with
;    ((#:make (x (cell-of? number?)) (y (cell-of? number?))) ; exported
;     ((Point #:maker) x y))
;    ((#:x (pt (Point #:?)))
;     ;(case-variant Point pt
;     (Point-case pt
;       (#:maker (x y) (x))))
;    ((#:x! (pt (Point #:?)) (arg number?))
;     ;(case-variant Point pt
;     (Point-case pt
;       (#:maker (x y) (x arg))))
;    ((#:y (pt (Point #:?)))
;     ;(case-variant Point pt
;     (Point-case pt
;       (#:maker (x y) (y))))
;    ((#:y! (pt (Point #:?)) (arg number?))
;     ;(case-variant Point pt
;     (Point-case pt
;       (#:maker (x y) (y arg))))
;    ))
;
;(define pt ((Point #:make) (cell 1) (cell 2)))
;
;(define-test (mutable-points?)
;  (not (condition-case ((Point #:maker) 10 20)
;         ((exn) #f)))
;  (= ((Point #:x) pt) 1)
;  (= ((Point #:x!) pt 10) 1) ; old value
;  (= ((Point #:x) pt) 10)
;  (= ((Point #:y) pt) 2)
;  (= ((Point #:y!) pt 20) 2) ; old value
;  (= ((Point #:y) pt) 20)
;  ((Point #:?) pt)
;  (not ((Point #:?) 5))
;  )
;
;(mutable-points?)
;
;
;(compound-test (DATATYPES)
;  (fvectors?)
;  (messages?)
;  (vargs?)
;  (options?)
;  (slists?)
;  (tuples?)
;  (abstract-lists?)
;  (mutable-points?)
;  )
;