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

(define-test (concrete-types?)
  (check
    "Immutable lists as 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)))
    ))

(define-test (abstract-types?)
  (check
    "Points as abstract types"
    (define-abstract-type POINT point?
      (Point (x number?) (y number?)) ; hidden
      (with
        ((make-point x y) (Point x y)) ; exported
        ((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 (make-point 1 2))
    (print pt)
    (= (point-x pt) 1)
    (point? pt)
    (not (point? Lst))
    ))

(define-test (object-types?)
  (check
    (define-object-type COUPLE couple? make-couple
      ((parent object?) (x (cell-of? number?)) (y (cell-of? number?)))
       (override)
       ; no overrides except those of base object
      ;; new messages with handlers
      ((First) (cell-ref x))
      ((Second) (cell-ref y))
      ((First-set! (arg number?))
       (set! (cell-ref x) arg))
      ((Second-set! (arg number?))
       (set! (cell-ref y) arg))
      )

    (define-object-type TRIPLE triple? make-triple
      ((parent couple?) (z (cell-of? number?)))
      (override ((First) (* 2 (parent (First))))
                ;; preconditions checked in parent
                ;; hence no predicates in args
                ((First-set! arg)
                 (parent (First-set! (* 2 arg)))))
      ((Third) (cell-ref z))
      ((Third-set! (arg number?))
       (set! (cell-ref z) arg))
      )

    (define-object-type FOO foo? make-foo
      ((parent object?) (x (cell-of? integer?)))
       (override)
       ; no overrides except those of base object
      ;; new messages with handlers
      ((First) (cell-ref x))
      ;; ueberschreibt die Argument-Typen von cpl und trp
      ((First-set! (arg integer?))
       (set! (cell-ref x) arg))
      )

    (define obj (make-base-object))
    (object? obj)
    (obj (Types))
    (obj (Invariant))
    (obj (Info))

    (define foo (make-foo obj (cell 101)))
    (= (foo (First)) 101)
    (foo (First-set! 202))
    (= (foo (First)) 202)
    
    (define cpl
      (make-couple obj (cell 1) (cell 2)))
    (couple? cpl)
    (object? cpl)
    (not (couple? First))
    (cpl (Types))
    (cpl (Info))
    (cpl (Invariant))
    (cpl (Ancestors))
    (= (cpl (First)) 1)
    (= (cpl (Second)) 2)
    (cpl (First-set! 10))
    (cpl (Second-set! 20))
    (= (cpl (First)) 10)
    (= (cpl (Second)) 20)
    
    (define trp (make-triple cpl (cell 3)))
    (trp (Ancestors))
    (trp (Info))
    (= (trp (Third)) 3)
    (trp (Third-set! 30))
    (= (trp (Third)) 30)
    (= (trp (First)) 20)
    (= (trp (Second)) 20)
    (trp (Second-set! 2))
    (= (trp (Second)) 2)
    (trp (First-set! 25))
    (= (trp (First)) 100)
    (triple? trp)
    (not (triple? cpl))
    (couple? trp)
    (object? trp)
    ))

(compound-test (DATATYPES)
  (concrete-types?)
  (abstract-types?)
  (object-types?)
  )