(import scheme (chicken base) (chicken fixnum) 
        generic-functions generic-helpers simple-tests)

(define-checks (List-helpers verbose?
                             xs '(0 1 2 3 4)
                             xss '(0 1 2 (3 4)))
  (map* add1 '(0 (1 (2 . 3)))) 
  '(1 (2 (3 . 4)))
  ((map* add1) '(0 (1 (2) 3) 4)) 
  '(1 (2 (3) 4) 5)
  ((map* add1) '(0 1 2))
  '(1 2 3)
  (map* add1 0)
  1
  ((repeat 3 add1) 0)
  3
  xs
  '(0 1 2 3 4)
  ((repeat 2 cdr) xs)
  '(2 3 4)
  (receive (yes no)
    ((filter odd?) xs)
    (list yes no))
  '((1 3) (0 2 4))
  (adjoin = 3 xs)
  xs
  ((adjoin = 5) xs)
  '(0 1 2 3 4 5)
  (insert-before = 20 60 xs)
  '(0 1 2 3 4 20)
  ((insert-before = 20 2) xs)
  '(0 1 20 2 3 4)
  (memp odd? xs)
  '(1 2 3 4)
  ((memp odd?) '(0 2 4))
  #f
  (assp odd? '((0 0) (1 10)))
  '(1 10)
  (assp odd? '((0 0) (2 20)))
  #f
  (condition-case (assp odd? '((0 0) 2 (1 10)))
    ((exn) #f))
  #f
  (let ((n (random-choice 0 1 2 3)))
    (if (memv n '(0 1 2 3)) #t #f))
  #t
  )

(define-checks (Splitting verbose? xs '(0 1 2 3 4))
  (receive (rhead tail)
    (rsplit-with odd? '(1 3 5 2 4 6))
    (list rhead tail))
  '(() (1 3 5 2 4 6))
  (receive (rhead tail)
    ((rsplit-with even?) '(1 3 5 2 4 6))
    (list rhead tail))
  '((5 3 1) (2 4 6))
  (receive (rhead tail)
    (rsplit-at 3 '(0 1 2 3 4 5 6))
    (list rhead tail))
  '((2 1 0) (3 4 5 6))
  (reverse* '(10 20 30) '(1 2 3 4 5))
  '(30 20 10 1 2 3 4 5)
  (reverse* '(10 20 30) '(1 2 3 4 5) list)
  '(30 (20 (10 (1 2 3 4 5))))
  (reverse* '(10 20 30) '0 list)
  '(30 (20 (10 . 0)))
  (reverse* '(10 20 30) '(0 . 1) list)
  '(30 (20 (10 (0 . 1))))
  (reverse* '(10 20 30) '((0 . 1) (0 . 2)) list)
  '(30 (20 (10 (0 . 1) (0 . 2))))
  xs
  '(0 1 2 3 4)
  (receive (head tail)
    (split-at 2 xs)
    (list head tail))
  '((0 1) (2 3 4))
  (receive (head tail)
    ((split-with odd?) xs)
    (list head tail))
  '((0) (1 2 3 4))
  (receive (head tail)
    (split-along '(a b . c) xs)
    (list head tail))
  '((0 1) (2 3 4))
  (receive (head tail)
    ((split-along '(a . b)) xs)
    (list head tail))
  '((0) (1 2 3 4))
  )
        
(define-checks (Predicates verbose?
                           xs '(0 1 2 3))
  (any? 5)
  #t
  (none? 5)
  #f
  ((all? number?) xs)
  #t
  ((all? odd?) xs)
  #f
  ((some? odd?) xs)
  #t
  (apply (always #t) xs)
  #t
  (for-all symbol? '(a b c))
  #t
  (for-all = '(1 2 3) '(1.0 2.0 3.0))
  #t
  (exists memq '(a b c) '((A a) (b B) (C c)))
  '(a)
  (exists memq '(a b c) '((A B) (b B) (C c)))
  '(b B)
  (exists symbol? '(#f #\a "b" 5))
  #f
  (in? = 2 0 1 2 3)
  #t
  (in? = 5 0 1 2 3)
  #f
  )

(mdefine* ys yss)

(define-checks (Accessors verbose?
                          xs '(0 1 2 3 4)
                          xss '(0 1 2 (3 4)))
  xs
  '(0 1 2 3 4)
  (cxr 'ad xs)
  1
  (cxr 'dd xs)
  '(2 3 4)
  ((cxr 'add) xs)
  2
  ((cxr 'addd) xs)
  3
  (cxr '(1 a 3 d) xs)
  3
  xss
  '(0 1 2 (3 4))
  (cxr '(1 a 3 d) xss)
  '(3 4)
  (cxr '(2 a 3 d) xss)
  3
  ((cxr '(1 a 1 a 3 d)) xss)
  3
  (cxr '(1 a 1 d 1 a 3 d) xss)
  4
  xss
  '(0 1 2 (3 4))
  (cxr 'addd xss)
  '(3 4)
  (cxr 'daddd xss)
  '(4)

  ys
  'ys
  yss
  'yss
  (mset! ys 1 yss 2)
  (void)
  ys
  1
  yss
  2
  )

(define-checks (Destructuring-lambda verbose?
                 count-test
                 (let ((count 0))
                   (dlambda
                     (reset () (set! count 0) count)
                     (inc   (n) (set! count (+ count n)) count)
                     (dec   (n) (set! count (- count n)) count)
                     (bound (lo hi)
                            (set! count
                              (min hi (max lo count))) count)
                     (else () #f)
                     ))
                 fac-test
                 (dlambda (fac (n) (if (zero? n)
                                     1
                                     (* n (fac (- n 1))))))
                 )
  (count-test 'reset)
  0
  (count-test 'inc 2)
  2
  (count-test 'inc 2)
  4
  (count-test 'dec 2)
  2
  (count-test 'bound 3 5)
  3
  (count-test 'inc 2)
  5
  (count-test 'bound 4 6)
  5
  (count-test 'bound 2 3)
  3
  (count-test 'reset)
  0
  (count-test)
  #f
  (fac-test 'fac 5)
  120
  )

(define-checks (Selectors verbose?)
  (selector? fixnum??)
  #t
  (map selector-name (selector-parents fixnum??))
  '(integer? number? any?)
  (selector-parent index??)
  any??
  ;; not eq? since different pointers:
  ;(selector-predicate index??)
  ;index?
  (selector-name number??)
  'number?
  ((selector-predicate number??) 5)
  (number? 5)
  ((selector-predicate number??) 'foo)
  (number? 'foo)
  )

(define item (method-tree-item (method +) number??))
(define tree
        (list (method-tree-item (method append) list?? list??)))
(define (fn+ x y) (+ x y))
(define (nf+ x y) (+ x y))
(define (nn+ x y) (+ x y))
(define-values (fff+ ffn+ fnf+ fnn+ nff+ nfn+ nnf+ nnn+)
  (values mfx+ + + + + + + +))
(define otree `((,fixnum?? (,fixnum?? (,fixnum?? . ,(method fff+))
                                      (,number?? . ,(method ffn+)))
                           (,number?? (,fixnum?? . ,(method fnf+))
                                      (,number?? . ,(method fnn+))))
                (,number?? (,fixnum?? (,fixnum?? . ,(method nff+))
                                      (,number?? . ,(method nfn+)))
                           (,number?? (,fixnum?? . ,(method nnf+))
                                      (,number?? . ,(method nnn+))))))

(define-checks (Trees verbose?)
  (method-tree-item? item)
  #t
  item
  `(,number?? . ,(method +))
  (method-tree? (list item))
  #t
  (method-tree-depth (list item))
  1

  (set! item (method-tree-item (method string-append) string?? string??))
  (void)
  (method-tree-item? item)
  #t
  item
  `(,string?? (,string?? . ,(method string-append)))
  (method-tree? (list item))
  #t
  (method-tree-depth (list item))
  2
  (cadr item)
  `(,string?? . ,(method string-append))
  (method-name (cdadr item))
  'string-append

  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method string-append)
                                              string??
                                              string??)))
  (void)
  (set! tree
        (method-tree-insert tree 
                            (method-tree-item (method +) number??  number??)))
  (void)
  (method-tree? tree)
  #t
  (method-tree-depth tree)
  2
  (method-tree-show tree)
  '((list? (list? . append))
    (string? (string? . string-append))
    (number? (number? . +)))
  (method-name (method-tree-dispatch tree '() '()))
  'append
  (method-tree-dispatch tree #t #t)
  #f
  (method-name (method-tree-dispatch tree 0 0))
  '+
  (method-name (method-tree-dispatch tree "" ""))
  'string-append
  (method-tree-dispatch tree '() 0)
  #f
  (method-tree-dispatch tree 0 '())
  #f
  (method-tree-dispatch tree 0 "")
  #f

  (set! tree
        (list (method-tree-item (method fx+) fixnum?? fixnum??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method fn+) fixnum?? number??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method nf+) number?? fixnum??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method nn+) number?? number??)))
  (void)
  (method-tree? tree)
  #t
  (method-tree-depth tree)
  2
  (method-tree-show tree)
  '((fixnum? (fixnum? . fx+)
              (number? . fn+))
    (number? (fixnum? . nf+)
              (number? . nn+)))
  (method-name (method-tree-dispatch tree 0.0 0.0))
  'nn+
  (method-name (method-tree-dispatch tree 0 0.0))
  'fn+
  (method-name (method-tree-dispatch tree 0.0 0))
  'nf+
  (method-name (method-tree-dispatch tree 0 0))
  'fx+
  (method-tree-dispatch tree #f 0)
  #f
  (method-tree-dispatch tree 0 #f)
  #f
  (method-tree-dispatch tree #f #f)
  #f

  (set! tree
        (list (method-tree-item (method nnn+) number?? number?? number??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method fff+)
                                              fixnum??
                                              fixnum??
                                              fixnum??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method ffn+)
                                              fixnum??
                                              fixnum??
                                              number??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method fnf+)
                                              fixnum??
                                              number??
                                              fixnum??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method fnn+)
                                              fixnum??
                                              number??
                                              number??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method nff+)
                                              number?? 
                                              fixnum??
                                              fixnum??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method nfn+)
                                              number??
                                              fixnum??
                                              number??)))
  (void)
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method nnf+)
                                              number??
                                              number??
                                              fixnum??)))
  (void)
  (method-tree? tree)
  #t
  (method-tree-depth tree)
  3
  (method-tree? otree)
  #t
  (method-tree-show tree)
  (method-tree-show otree)
  (method-name (method-tree-dispatch tree 0 0 0))
  'fff+
  (method-name (method-tree-dispatch tree 0.0 0 0))
  'nff+
  (method-name (method-tree-dispatch tree 0 0 0.0))
  'ffn+
  (method-name (method-tree-dispatch tree 0 0.0 0.0))
  'fnn+
  (method-name (method-tree-dispatch tree 0 0.0 0))
  'fnf+
  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
  'nnn+

  ;; override nnn+ with +
  (set! tree
        (method-tree-insert tree
                            (method-tree-item (method +)
                                              number??
                                              number??
                                              number??)))
  (void)
  (method-name (method-tree-dispatch tree 0.0 0.0 0.0))
  '+
  (method-tree-dispatch tree 0 0 #f)
  #f
  (method-tree-dispatch tree 0 #f #f)
  #f
  (method-tree-dispatch tree #f 0 0)
  #f
  (method-tree-dispatch tree 0.0 0.0 #f)
  #f
  (method-tree-dispatch tree 0.0 0 #f)
  #f
  (method-tree-dispatch tree 0.0 #f 0.0)
  #f
  )

(define-generic (Add x y) (error 'Add "no method found"))
(define-method (Add (x number??) (y number??)) (+ x y))
(define-generic (At k seq) (error 'At "no method found"))
(define-method (At (k index??) (seq list??)) (list-ref seq k))
(define-generic (Drop k seq) (error 'Drop "no method found"))
(define-method (Drop (k index??) (seq list??)) (list-tail seq k))
(define-generic (Take k seq) (error 'Take "no method found"))
(define-method (Take (k index??) (seq list??))
                ;(compress (make-list k #t) seq))
                (let loop ((n 0) (lst seq) (result '()))
                  (if (fx= n k)
                    (reverse result)
                    (loop (1+ n)
                          (cdr lst)
                          (cons (car lst) result)))))
(define-generic (Add* . xs) (error 'Add* "no method found"))
(define-method (Add* xs number??) (apply + xs))

(define-checks (Generic-functions verbose? seq '(0 1 2 3 4))
  (define-method  (Add (x fixnum??) (y fixnum??)) (fx+ x y))
  (void)
  (generic? Add)
  #t
  (generic-variadic? Add)
  #f
  (generic-arity Add)
  2
  (Add 1 2.0)
  3.0
  (Add 1 2)
  3
  (condition-case (Add 1) ((exn) #f))
  #f
  (condition-case (Add 1 #f) ((exn) #f))
  #f

  (At 2 seq)
  2
  (Drop 2 seq)
  '(2 3 4)
  (Take 2 seq)
  '(0 1)
  (generic? At)
  #t
  (generic-variadic? At)
  #f
  (generic-arity At)
  2
  (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
  (void)
  (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
  (void)
  (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
  (void)
  (define-method (At (k index??) (seq string??)) (string-ref seq k))
  (void)
  (define-method (Drop (k index??) (seq string??)) (substring seq k))
  (void)
  (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
  (void)
  (generic-variadic? At)
  #f
  (generic-arity Take)
  2
  (Drop 2 "abcde")
  "cde"
  (At 2 seq)
  2
  (Take 2 #(0 1 2 3 4))
  #(0 1)

  (define-method (Add* xs list??) (apply append xs))
  (void)
  (Add* 1 2 3)
  6
  (Add* '(1) '(2) '(3))
  '(1 2 3)
  (define-method (Add* xs string??) (apply string-append xs))
  (void)
  (Add* "1" "2" "3")
  "123"
  (condition-case (Add* 1 #f 3) ((exn) #f))
  #f
  (generic? Add*)
  #t
  (generic-variadic? Add*)
  #t
  (generic-arity Add*)
  1
  )

(check-all GENERICS
  (List-helpers)
  (Splitting)
  (Predicates)
  (Accessors)
  (Destructuring-lambda)
  (Selectors)
  (Trees)
  (Generic-functions)
  )