(import functional-vectors messages bindings (chicken keyword) checks simple-cells simple-tests) 

(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)))
  )

(define fvectors (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))
  )

(define messages (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))
  )

(define vargs (vargs?))

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

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

(define (qux opt)
  (case-variant Option opt
    (#: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)
)

(define options (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)))
  )

(define slists (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
                   (#:maker (parent z) parent)))
            (sgl (case-variant Couple cpl
                   (#:maker (parent y) parent))))
       (case-variant Single sgl
         (#:maker (x) x))))
  (= 2
     (let ((cpl (case-variant Triple trp
                  (#:maker (parent z) parent))))
       (case-variant Couple cpl
         (#:maker (parent y) y))))
  (= 3
     (case-variant Triple trp
       (#:maker (parent z) z)))
  )

(define tuples (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 sequence) #f)))
  )

(define lists (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
       (#:maker (x y) (x))))
    ((#:x! (pt (Point #:?)) (arg number?))
     (case-variant Point pt
       (#:maker (x y) (x arg))))
    ((#:y (pt (Point #:?)))
     (case-variant Point pt
       (#:maker (x y) (y))))
    ((#:y! (pt (Point #:?)) (arg number?))
     (case-variant Point 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))
  )

(define points (mutable-points?))

(print "\nRects and Squares as object types")
(print "---------------------------------")

(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?))
   (let ((x (x%)) (y (y%)))
     (x% (+ dx x)) 
     (y% (+ dy y))
     (list x y)))
  ((#:scale! (r number?))
   (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)))

(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))
     (list old-w old-h)))
  )

(define square
  (Square-instance
    (Rect-instance (cell 0) (cell 0) (cell 1) (cell 1))))

(define-object-type Bar
  (state (as number?) #t)
  ((#:xs) as))

(define bar (Bar-instance 1 2 3))

(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?)))
;     )

(define-test (object-types?)
  (Rect-instance? rect)
  (message? ((Rect #:x)))
  (= (rect ((Rect #:x))) 0);10)
  (zero? (rect ((Rect #:y))))
  (= (rect ((Rect #:w!) 5)) 1)
  (= (rect ((Rect #:w))) 5)
  (= (rect ((Rect #:h))) 1)
  (rect ((Rect #:invariant?)))
  (= 1 (square ((Square #:w))))
  (= 1 (square ((Square #:w!) 50)))
  (= 50 (square ((Square #:w))))
  (= 50 (square ((Square #:h))))
  (= (rect ((Rect #:w))) 5)
  (= (rect ((Rect #:h))) 1)
  (square ((Square #:invariant?)))
  ;(rect ((Square #:invariant?))) ; rect is not a Square instance
  (square ((Rect #:invariant?)))
  (Bar-instance? bar)
  (not (Bar-instance? square))
  (equal? (bar ((Bar #:xs))) '(1 2 3))
  (bar ((Bar #:invariant?)))
  (not (Baz-instance? bar))
  (Baz-instance? baz)
  (zero? (baz ((Baz #:x))))
  (equal? (baz ((Baz #:xs))) '(1 2 3))
  (baz ((Baz #:invariant?)))
  )

(define objects (object-types?))

(compound-test (DATATYPES)
  fvectors
  messages ;(messages?)
  vargs
  options  ;(options?)
  slists   ;(slists?)
  tuples   ;(tuples?)
  lists    ;(abstract-lists?)
  points   ;(mutable-points?)
  objects  ;(object-types?)
  )