(require (only (lib "etc.ss") this-expression-source-directory))
(let ((cd (this-expression-source-directory)))
 (let ((lcp (simplify-path (build-path cd 'up 'up))) (clcps (current-library-collection-paths)))
  (if (not (member lcp clcps))
   (let ((clcps (cons lcp clcps)))
    (printf "Current directory: ~a~n" cd)
    (current-library-collection-paths clcps)
    (for-each (lambda (clcp) (printf "Current collection path: ~a~n" clcp)) clcps)))))
(require 
 (lib "test/compiled/test.zo" "kcollects")
 (lib "records/compiled/records.zo" "kcollects"))
(print-struct #f)
(define-values (make-x x?) (make-record-type 'x #f '(a b c)))
(define an-x (make-x 1 2 3))
(test 0 ((printf "~s~n" an-x)) (,(void)) "#<procedure>")
(test 1 (an-x.a) (1))
(test 2 ((printf "~s~n" (an-x))) (,(void))
"(#<procedure> #f #<primitive:x?> ((a . 1) (b . 2) (c . 3)))")
(set! an-x.a 10)
(test 3 (an-x.a) (10))
(define-values (make-y y?) (make-record-type 'y make-x '(d e f)))
(define an-y (make-y 1 2 3 4 5 6))
(test 4 ((x? an-y)) (#t))
(test 5 ((y? an-y)) (#t))
(test 6 ((record? an-y)) (#t))
(test 7 ((map an-y '(a b c d e f))) ((1 2 3 4 5 6)))
(test 8 ((printf "~s~n" (an-y))) (,(void))
"(#<procedure> #<procedure> #<primitive:y?> ((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))")
(set! an-y.d an-x)
(test 9 (an-y.d.a) (10))
(test 10 ((record? an-y.d)) (#t))
(test 11 ((let ((an-y.d 333)) an-y.d)) (333)) ; this is against the rule that identifiers must not contain dots.
(define an-y.d 444)
(test 12 ((printf "~s" an-y.d)) (,(void)) "#<procedure>")

(test 13
 ((printf "~s~n"
   (letrec-record-types (((constr1 pred1) (name1 #f (a b c))) ((constr2 pred2) (name2 constr1 (d e f))))
    (letrec-records ((r1 (constr1 10 20 30)) (r2 (constr2 1 2 3 4 5 6)))
     (let ((a (list (pred1 r1) (pred2 r1) (pred1 r2) (pred2 r2) (r1) (r2))))
      (r2 'a 11)
      (cons (r2) a))))))
 (,(void))
 "((#<procedure> #<procedure> #<primitive:name2?> ((a . 11) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) #t #f #t #t (#<procedure> #f #<primitive:name1?> ((a . 10) (b . 20) (c . 30))) (#<procedure> #<procedure> #<primitive:name2?> ((a . 11) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))))")

(test 14
 ((printf "~s~n"
   (letrec-record-types (((constr1 pred1) (name1 #f (a b c))) ((constr2 pred2) (name2 constr1 (d e f))))
    (letrec-records ((r1 (constr1 10 20 30)) (r2 (constr2 1 2 3 4 5 6)))
     (let ((a (list (pred1 r1) (pred2 r1) (pred1 r2) (pred2 r2) (r1) (r2))))
      (r2 'a 11)
      (let ((r3 (copy-record r2)))
       (r3 'a 22)
       (list (r3) (r2) a)))))))
 (,(void))
 "((#<procedure> #<procedure> #<primitive:name2?> ((a . 22) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) (#<procedure> #<procedure> #<primitive:name2?> ((a . 11) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) (#t #f #t #t (#<procedure> #f #<primitive:name1?> ((a . 10) (b . 20) (c . 30))) (#<procedure> #<procedure> #<primitive:name2?> ((a . 11) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))))")


(define-values (ma a?) (make-record-type 'a #f '(a b c)))
(define-values (mb b?) (make-record-type 'b ma '(d e f)))
(define-values (mc c?) (make-record-type 'c mb '(g h i)))
(define r (mc 1 2 3 4 5 6 7 8 9))
(test 15 ((printf "~s~n" (map constr-info (list ma mb mc)))) (,(void))
"((#f #<primitive:a?> (a b c))
 (#<procedure> #<primitive:b?> (a b c d e f))
 (#<procedure> #<primitive:c?> (a b c d e f g h i)))")
(test 16 ((printf "~s~n" ((ma 1 2 3)))) (,(void)) "(#<procedure> #f #<primitive:a?> ((a . 1) (b . 2) (c . 3)))")
(test 17 ((printf "~s~n" ((mb 1 2 3 4 5 6)))) (,(void))
"(#<procedure> #<procedure> #<primitive:b?> ((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))")
(test 18 ((printf "~s~n" ((mc 1 2 3 4 5 6 7 8 9)))) (,(void))
"(#<procedure> #<procedure> #<primitive:c?> ((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6) (g . 7) (h . 8) (i . 9)))")
(test 19
 ((define-values (c sc p a) (apply values (r)))
  (printf "~s~n" ((sc 1 2 3 4 5 6)))
  (define-values (c1 sc1 p1 a1) (apply values ((sc 1 2 3 4 5 6))))
  (printf "~s~n" ((sc1 1 2 3)))
  (define-values (c2 sc2 p2 a2) (apply values ((sc1 1 2 3))))
  sc2)
 (#f)
 "(#<procedure> #<procedure> #<primitive:b?> ((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))
  (#<procedure> #f #<primitive:a?> ((a . 1) (b . 2) (c . 3)))")

(test 20
 ((make-record-type 'wrong #f '(a a)))
 ()
 ""
 "make-record-type: duplicate field-name a")

(test 21
 ((define-values (c p) (make-record-type 'a #f '(a)))
  (make-record-type 'b c '(a)))
 ()
 ""
 "make-record-type: duplicate field-name a")

(test 22 ((make-record-type 1 2 3)) () "" "make-record-type: name must be a symbol, given: 1")
(test 23 ((make-record-type 'a #f 3)) () "" "make-record-type: all field-names must be symbols, given: 3")
(test 24 ((make-record-type 'a #f '(3))) () "" "make-record-type: all field-names must be symbols, given: (3)")
(test 25 ((copy-record 1)) () "" "copy-record: record expected, given: 1")
(test 26
 ((define (c p) (make-record-type 'a #f '(b c)))
  (c 1 2 3))
 ()
 ""
 "procedure c: expects 1 argument, given 3: 1 2 3")

(define-values (make-person person?) (make-record-type 'person #f '(name maried-with children)))
(define jacob (make-person 'jacob #f ()))
(define maria (make-person 'maria #f ()))
(define (mary man woman)
 (set! man.maried-with woman)
 (set! woman.maried-with man))
(define (birth mother father name)
 (let ((child (make-person name #f ())))
  (set! mother.children (cons child mother.children))
  (set! father.children (cons child father.children))))
(define (names-of-children person) (map (lambda (person) person.name) person.children))
(mary jacob maria)
(birth maria jacob 'son)
(birth maria jacob 'doughter)
(test 27 ((names-of-children maria)) ((doughter son)))

(test-report)