(require-library datatypes cells simple-tests)
(import datatypes cells simple-tests) 

(define-test (datatypes?)
  (check

    "Concrete types"
    (define-concrete-type LIST List?
      (List-null)
      (List-cons (first) (rest List?)))

    (define (Null? obj)
      (concrete-case (obj List?)
        ((List-null) #t)
        (else #f)))
    (define (List-first obj)
      (concrete-case (obj List?)
        ((List-null)
         (error 'List-first))
        ((List-cons first rest)
         first)))
    (define (List-rest obj)
      (concrete-case (obj List?)
        ((List-null)
         (error 'List-rest))
        ((List-cons first rest)
         rest)))
    (define Lst (List-null))
    (Null? Lst)
    (set! Lst (List-cons 1 Lst))
    (not (Null? Lst))
    (Null? (List-rest Lst))
    (= 1 (List-first Lst))

    "Integers as chains"
    (define-concrete-type CHAIN chain?
      (Chain-link (item integer? (lambda (x) (>= x 0)))
                  (next procedure?)))
    (define (integers n) 
      (Chain-link n integers))
    (not (chain? integers))
    (chain? (integers 0))
    (chain? (integers 10))
    (define (chain-item n xpr)
      (concrete-case (xpr chain?)
        ((Chain-link i fn)
         (if (= n 1)
           i
           (chain-item (- n 1) (fn (+ i 1)))))))
    (= 0 (chain-item 1 (integers 0)))
    (= 25 (chain-item 26 (integers 0)))

    "Abstract types"
    (define-abstract-type POINT point?
      (Point (x number?) (y number?))
      (with
        ((point x y) (Point x y))
        ((point-x pt)
         (concrete-case (pt point?)
           ((Point x y) x)))
        ((point-y pt)
         (concrete-case (pt point?)
           ((Point x y) y))))
      (printer
        (lambda (pt out)
          (display "#,(POINT " out)
          (display (point-x pt) out)
          (display " " out)
          (display (point-y pt) out)
          (display ")\n" out)))
      (reader Point))
    (define pt (point 1 2))
    (print pt)
    (= (point-x pt) 1)
    (point? pt)
    (not (point? Lst))
))

(define-test (objects?)
  (check
    (define-object-type POINT point? make-point
      ((parent object?) (x (cell-of? number?)) (y (cell-of? number?)))
       (override)
       ; no overrides except those of base object
      ;; new messages with hanlers
      ((X) (cell-ref x))
      ((Y) (cell-ref y))
      ((X-set! (arg number?))
       (set! (cell-ref x) arg))
      ((Y-set! (arg number?))
       (set! (cell-ref y) arg))
      )
    (define-object-type POINT_3D point-3d? make-point-3d
      ((parent point?) (z (cell-of? number?)))
      (override ((X) (* 2 (parent (X))))
                ;; preconditions checked in parent
                ;; hence no predicates in args
                ((X-set! arg)
                 (parent (X-set! (* 2 arg)))))
      ((Z) (cell-ref z))
      ((Z-set! (arg number?))
       (set! (cell-ref z) arg))
      )
    (define obj (make-base-object))
    (object? obj)
    (obj (Types))
    (obj (Invariant))
    (obj (Info))
    (define p2
      (make-point obj (cell 1) (cell 2)))
    (point? p2)
    (object? p2)
    (not (point? X))
    (p2 (Types))
    (p2 (Info))
    (p2 (Invariant))
    (p2 (Ancestors))
    (= (p2 (X)) 1)
    (= (p2 (Y)) 2)
    (p2 (X-set! 10))
    (p2 (Y-set! 20))
    (= (p2 (X)) 10)
    (= (p2 (Y)) 20)
    (define p3 (make-point-3d p2 (cell 3)))
    (p3 (Ancestors))
    (p3 (Info))
    (= (p3 (Z)) 3)
    (p3 (Z-set! 30))
    (= (p3 (Z)) 30)
    (= (p3 (X)) 20)
    (= (p3 (Y)) 20)
    (p3 (Y-set! 2))
    (= (p3 (Y)) 2)
    (p3 (X-set! 25))
    (= (p3 (X)) 100)
    (point-3d? p3)
    (not (point-3d? p2))
    (point? p3)
    (object? p3)
    ))


(compound-test (DATATYPES)
  (datatypes?)
  (objects?)
  )