;;; File: tests/run.scm
;;; Author: Juergen Lorenz
;;; ju (at) jugilo (dot) de

(import simple-tests
        bindings
        (chicken base)
        (chicken condition)
        biglists
        )

(define stack #f) (define push! #f) (define pop! #f)

(define-checks (defines? verbose?)
  (let ((x #f) (y #f) (z #f))
    (bind! (x (y . z))
      '(1 #(2 3 3)))
    (list x y z))
  '(1 2 #(3 3))
  (let ((x #f) (y #f) (z #f))
    (bind! (x #f _ (y _ . z))
      '(1 #f 10 #(2 30 3 3)))
    (list x y z))
  '(1 2 #(3 3))
  (let ((x #f) (y #f) (z #f))
    (bind! x 1)
    (bind! y 2)
    (bind! z 3)
    (list x y z))
  '(1 2 3)
  (let ((x #f) (y #f) (z #f) (u #f) (v #f))
    (bind! (x (y . z)) '(1 #(2 3 3)))
    (bind! (u (v)) '(10 (20)))
    (list x y z u v))
  '(1 2 #(3 3) 10 20)
  (let ((x #f) (y #f) (z #f))
    (bind! (x (y . z))
      '(1 #(2 3 3)))
    (list x y z))
  '(1 2 #(3 3))
  (let ((state #f) (push! #f) (pop! #f))
    (bind! (state (push! pop!))
      (list '()
            (vector
              (lambda (xpr) (set! state (cons xpr state)))
              (lambda () (set! state (cdr state))))))
    (push! 1)
    (push! 0)
    state)
  '(0 1)
  (begin
    (bind! (plus5 times5)
      (let ((a 5))
        (list
          (lambda (x) (+ x a))
          (lambda (x) (* x a)))))
    (list (plus5 6) (times5 6)))
  '(11 30)
  (begin
    (bind! (x . y) '(1 . 2))
    (list x y))
  '(1 2)
  (begin
    (bind! (x _ . y) '(1 10 . 2))
    (list x y))
  '(1 2)
  (begin
    (bind! (x #f . y) '(1 #f . 2))
    (list x y))
  '(1 2)
  (begin
    (let ((lst '()))
      (bind! (push top pop)
        (vector
          (lambda (xpr) (set! lst (cons xpr lst)))
          (lambda () (car lst))
          (lambda () (set! lst (cdr lst))))))
    (push 0)
    (push 1)
    (pop)
    (top))
  0
  (begin
    (bind! (x (_ y (z _))) '(1 #(2 3 (4 5))))
    (list x y z))
  '(1 3 4)
  (begin
    (bind! (x (#f y (z #t)))
      (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
    (list x y z))
  '(1 3 4)
  (let ()
    (bind! (a _ (b #f . bs) c))
    (and (eq? a 'a) (eq? b 'b) (eq? bs 'bs) (eq? c 'c)))
  #t
  )
;(defines?) ; ok

(define-checks (binds? verbose?)
  (bind a 1 a)
  1
  (bind (a #f) '(1 #f) a)
  1
  (bind (a b) '(1 2) (list a b))
  '(1 2)
  (bind (x . y) #(1 2 3 4) (list x y))
  '(1 #(2 3 4))
  (bind (_ . y) #(1 2 3 4) y)
  '#(2 3 4)
  (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
    (list x y z u v w))
  '(1 2 #\f #\o "o" 4)
  (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
    (list x y z u w))
  '(1 2 #\f #\o 4)
  (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
  '(1 2)
  (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
  '(1 2)
  (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6)
    (list x y z u v w))
  '(1 2 #f #f 5 #(6))
  (bind (x (y (#f . u)) v . w)
    (vector 1 (list 2 (cons (odd? 4) #f)) 5 6)
    (list x y u v w))
  '(1 2 #f 5 #(6))
  (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6)
    (list x y z u v w))
  '(1 2 3 4 5 #(6))

  (bind (as ...) '(1 2 3) (list as))
  '((1 2 3))
  (bind (x y as ...) '(-1 0 1 2 3) (list x y as))
  '(-1 0 (1 2 3))
  (bind (x y as ..) '(-1 0)  (list x y as))
  '(-1 0 ())
  (bind ((as (bs cs)) ...)
        '((1 (2 3)) (10 (20 30)))
        (list as bs cs))
  '((1 10) (2 20) (3 30))
  (bind ((as (bs cs)) ...)
        '((1 (2 3)) #(10 (20 30)))
        (list as bs cs))
  '((1 10) (2 20) (3 30))

  (bind-loop (x (a . b) y) '(5 #(1) 0)
    (if (zero? x)
      (list x a b y)
      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
  '(0 1 (1 1 1 1 1 . #()) 5)
  (bind* loop (x (a . b) y) '(5 #(1) 0)
    (if (zero? x)
      (list x a b y)
      (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
  '(0 1 (1 1 1 1 1 . #()) 5)
  (bind-loop (x y) #(5 0)
    (if (zero? x)
      (vector x y)
      (loop (vector (- x 1) (+ y 1)))))
  '#(0 5)
  (bind* loop (x y) #(5 0)
    (if (zero? x)
      (vector x y)
      (loop (vector (- x 1) (+ y 1)))))
  '#(0 5)
  ;LITERALS
  (bind (#f . ys) '(#f 2 3) ys)
  '(2 3)
  (condition-case
    (bind (#f . ys) '(#t 2 3) ys)
    ((exn) #f))
  #f
  (bind #f #f #t)
  #t
  (condition-case
    (bind #f #t #t)
    ((exn) #f))
  #f
  (condition-case
    (bind (x . #f) '(1 . #t) x)
    ((exn) #f))
  #f
  (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
  '(1 2)
  (condition-case
    (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
    ((exn) #f))
  #f
  (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
  '(1 2)
  (condition-case
    (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
    ((exn) #f))
  #f
  (condition-case
    (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
    ((exn) #f))
  #f
  (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))
  '(1 2 3)
  (bind (a: ()) #(a: #()) #f)
  #f
  )
;(binds?) ; ok

(define-checks (predicates? verbose?)
  ((bindable? (x)) '(name 1))
  #f
  ((bindable? (_ x)) '(name 1 2))
  #f
  ((bindable? (a b)) '#(1 2))
  #t
  ((bindable? (x (y z))) '(1 "23"))
  #t
  ((bindable? (x (y . z))) '(1 "23"))
  #t
  ((bindable? (x y)) '(1 "23"))
  #t
  ((bindable? (a (b . c) . d)) '(1 2 3 4 5))
  #f
  ((bindable? (a)) 1)
  #f
  (bindable? (a b) (where (even? a) (odd? b)) '(2 2))
  #f
  (bindable? (a (b cs .. d)) '(1 (2 3)))
  #t
  )
;(predicates?) ; ok

(define my-map #f)
(define vector-map #f)
(define vector-revrerse #f)

(define-checks (cases? verbose?)
  (bind-case #() (() #f))
  #f
  (bind-case #(2 2)
    ((a b) (where (even? a) (odd? b)) (print 'even-odd a b))
    ((a b) (where (odd? a) (even? b)) (print 'odd-even a b))
    ((a b) (list a b)))
  '(2 2)
  (bind-case '(1 "2 3")
    ((x (y z)) #f)
    ((x (y . z)) (list x y z))
    ((x y) #t))
  '(1 #\2 " 3")
  (bind-case '(1 "23")
    ((x (y z)) (where (char-alphabetic? y)) #f)
    ((x (y . z)) (list x y z))
    ((x y) #t))
  '(1 #\2 "3")
  (bind-case '(1 "23")
    ((x (y z)) (where (char-alphabetic? y)) #f)
    ((x (y . _)) (list x y))
    ((x y) #t))
  '(1 #\2)
  (bind-case '(1 "23")
    ((x (y z)) (where (char-numeric? y)) (list x y z))
    ((x (y . z)) #t)
    ((x y) #t))
  '(1 #\2 #\3)
  (bind-case '(1 "23")
    ((x (y z)) (list x y z))
    ((x (y . z)) #t)
    ((x y) #t))
  '(1 #\2 #\3)
  (bind-case '(1 "2 3") ;
    ((x (y . z)) (list x y z))
    ((x (y z)) #f)
    ((x y) #t))
  '(1 #\2 " 3")
  (bind-case '(1 #(2 3))
    ((x y) (where (list? y)) #f)
    ((x (y . z)) (list x y z))
    ((x (y z)) #t))
  '(1 2 #(3))
  (bind-case '(1 (2 3))
    ((x y) (list x y))
    ((x (y . z)) #t)
    ((x (y z)) #t))
  '(1 (2 3))
  (bind-case '(1 (2 . 3))
    ((x y) (list x y))
    ((x (y . z)) #t)
    ((x (y z)) #f))
  '(1 (2 . 3))
  (bind-case '#(1 2)
    ;(() #f)  ;;;;;;;
    ((a) #f)
    ((a b) (list a b))
    ((a b c) #f))
  '(1 2)

  (bind-case '(0 4)
    ((a bs ....) #f)
    ((a bs ...) (list a bs)))
  #f
  (bind-case '(0 1 2 3 4)
    ((a bs ..) #f)
    ((a bs ...) (list a bs)))
  '(0 (1 2 3 4))
  (bind-case '(0 #(1 (2 3)))
    ((a (bs (cs (ds))) ..) #f)
    ((a (bs (cs ds)) ..) (list a bs cs ds))) 
  '(0 (1) (2) (3))
  (bind-case '(0)
    ((a (bs (cs (ds))) ..) (list a bs cs ds))
    ((a (bs (cs ds)) ..) #t))
  '(0 () () ())
  (bind-case '((0 1 2 3) (10 #(20 30)))
    (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs)))
  '(0 (1 2 3) 10 (20) (30)) 

  ;LOCAL VARIABLES IN ALL RULES
  (set! my-map
    (lambda (fn lst)
      (let loop ((lst lst) (result '()))
        (bind-case lst
          (() (reverse result))  ;;;;;
          ((x . xs)
           (loop xs (cons (fn x) result)))))))
  (void)
  (my-map add1 '(0 1 2 3))
  '(1 2 3 4)
  (set! vector-map
    (lambda (fn vec)
      (let* ((len (vector-length vec))
             (result (make-vector len #f)))
        (let loop ((vec vec))
          (bind-case vec
            (() result)  ;;;;;;;
            ((x . xs)
             (vector-set! result
                          (- len (vector-length xs) 1)
                          (fn x))
             (loop (subvector vec 1))))))))
  (void)
  (vector-map add1 #(0 1 2 3))
  #(1 2 3 4)
  (set! vector-reverse
    (lambda (vec)
    (let ((result (make-vector (vector-length vec) #f)))
      (let loop ((vec vec))
        (bind-case vec
          (() result)
          ((x . xs)
           (vector-set! result
                        (vector-length xs)
                        x)
           (loop (subvector vec 1))))))))
  (void)
  (vector-reverse #(0 1 2 3))
  #(3 2 1 0)

  ;NON-SYMBOL LITERALS
  (bind-case #("a")
    ((#f) #f)
    (("a") #t))
  #t
  (bind-case (vector 1 (list (odd? 2) 3))
    ((x y) (where (number? y)) #f)
    ((x ("y" . z)) #f)
    ((x (#f z)) (list x z)))
  '(1 3)
  (bind-case '(1 (#f 3))
    ((x y) (list x y))
    ((x ("y" . z)) #f)
    ((x (#f z)) (list x z)))
  '(1 (#f 3))
  (bind-case #(1 ("y" 3))
    ((x ("y" . z)) (list x z))
    ((x (#f z)) #f))
  '(1 (3))
  (bind-case '((0 1 2 3) ("" #(20 30)))
    (((a bs ...) ("x" (ys zs) ..)) #f)
    (((a bs ...) ("" (ys zs) ..)) (list a bs ys zs)))
  '(0 (1 2 3) (20) (30)) 

  (bind-case '((0 1 2 3) (10 #(20 30)))
    (((_ bs ...) (_ (ys zs) ..)) (list bs ys zs)))
  '((1 2 3) (20) (30)) 
  )
;(cases?)

(define-checks (lambdas? verbose?)
  ((bind-lambda (a (b cs ...) ds ...)
     (list a b cs ds))
   '(1 #(20 30 40) 2 3))
  '(1 20 #(30 40) (2 3))
  ((bind-lambda (a (b (cs ds) ...) . es)
     (list a b cs ds es))
   '(1 (20 (30 40)) 2 3))
   ;'(1 #(20 (30 40)) 2 3))
  '(1 20 (30) (40) (2 3))
  ((bind-lambda (a (b . cs) . ds)
     (list a b cs ds))
   '(1 #(20 30 40) 2 3))
  '(1 20 #(30 40) (2 3))
  ((bind-lambda* ((a (b . c) . d) (e . f))
     (list a b c d e f))
   '(1 #(20 30 40) 2 3) '#(4 5 6))
  '(1 20 #(30 40) (2 3) 4 #(5 6))
  ((bind-case-lambda
     ((e . f) (where (zero? e)) f)
     ((e . f) (list e f)))
   '#(0 2 3 4 5))
  '#(2 3 4 5)
  ((bind-case-lambda
     ((e . f) (where (zero? e)) #f)
     ((a (b . #f) . d) (list a b d))
     ((e . f) #f))
   '(1 (2 . #f) 4 5))
  '(1 2 (4 5))
  ((bind-case-lambda
     ((e . f) (where (zero? e)) #f)
     ((a (b . #f) (ds es) ...) (list a b ds es))
     ((e . f) #f))
   '(1 (2 . #f) (4 5) (40 50)))
  '(1 2 (4 40) (5 50))
  ((bind-case-lambda
     ((e . f) (where (zero? e)) #f)
     ((a (b . #f) . d) #f)
     ((e . f) (list e f)))
   '(1 (2 . #t) 4 5))
  '(1 ((2 . #t) 4 5))
  (condition-case
    ((bind-case-lambda
       ((e . f) (where (zero? e)) #f)
       ((a (b . #f) . d) #f))
     '(1 (2 . #t) 4 5))
    ((exn) #f))
    #f
  ((bind-case-lambda
     ((e . f) (where (zero? e)) #f)
     ((a (b "c") . d) (list a b d))
     ((e . f) #f))
   '(1 (2 "c") 4 5))
  '(1 2 (4 5))
  ((bind-case-lambda
     ((a (b . c) . d) (where (integer? a)) (list a b c d))
     ((e . f) (list e f)))
   '(1 #(2 3 4) 5 6))
  '(1 2 #(3 4) (5 6))
  ((bind-case-lambda
     ((a (b . c) . d) (where (string? a)) #f)
     ((e . f) (list e f)))
   '(1 #(2 3 4) 5 6))
  '(1 (#(2 3 4) 5 6))
  ((bind-case-lambda*
     (((a b c . d) (e . f))
      (list a b c d e f)))
   '(1 2 3) #(4 5 6))
  '(1 2 3 () 4 #(5 6))
  ((bind-case-lambda*
     (((a (b . c) . d) (e . f))
      (list a b c d e f)))
   '(1 #(20 30 40) 2 3) '(4 5 6))
  '(1 20 #(30 40) (2 3) 4 (5 6))
  )
;(lambdas?)

(define-checks (lets? verbose?)
  (bind-let ((((x y) z) '(#(1 2) 3))
             (u (+ 2 2))
             ((v w) #(5 6)))
    (list x y z u v w))
  '(1 2 3 4 5 6)
  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
             (u (+ 2 2))
             ((v w) #(5 6)))
    (list x y zs u v w))
  '(1 2 () 4 5 6)
  (bind-let ((((x y) (zs ..)) '(#(1 2) ()))
             (((us vs) ...) '((3 4) (30 40) (300 400))))
    (list x y zs us vs))
  '(1 2 () (3 30 300) (4 40 400))
  (bind* loop (a b) '(5 0)
    (if (zero? a)
      (list a b)
      (loop (list (- a 1) (+ b 1)))))
  '(0 5)
  (bind-let loop (((a b) '(5 0)))
    (if (zero? a)
      (list a b)
      (loop (list (- a 1) (+ b 1)))))
  '(0 5)
  (bind-let loop (((x . y) '(1 2 3))
                  ((z) #(10)))
    (if (zero? z)
      (list x y z)
      (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
  '(11 (12 13) 0)
  (bind-let* ((((x y) z) '(#(1 2) 3))
              (u (+ 1 2 x))
              ((v w) (list (+ z 2) 6)))
    (list x y z u v w))
  '(1 2 3 4 5 6)
  (bindrec ((o?) e?)
    (vector
      (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
      (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    (list (o? 95) (e? 95)))
  '(#t #f)
  (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
                ((e?)
                 (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    (list (o? 95) (e? 95)))
  '(#t #f)
  )
;(lets?)

(define (integers-from n)
  (Cons n (integers-from (+ n 1)) #f))
(define integers (integers-from 0))
(define 5integers (Take 5 integers))
(define standard-checkers (sequence-db))
(define checkers
  ;; add finite lazy list handlers at the front
  (sequence-db List?
               Length 
               (lambda (xs k) (At k xs))
               (lambda (xs k) (Drop k xs))
               List
               list?))

(define-checks (biglists? verbose?)
  (if (memq List? standard-checkers) #t #f)
  #f
  (if (memq List? checkers) #t #f)
  #t
  (car checkers)
  List?
  (List? 5integers)
  #t
  (bind (x y . zs) 5integers (At 0 zs))
  2
  (bind (_ _ . zs) 5integers (At 0 zs))
  2
  (bind (x #f (_ (b . cs) . zs))
        (vector 1 #f (List 10 5integers 2 3))
        (list x b (At 0 cs) (At 0 zs) (At 1 zs)))
  '(1 0 1 2 3)
  )
;(biglists?)

;(define-checks (dots? verbose?)
;  (resolve-dots '(1 2 3) ...)
;  '(1 2 3)
;  (resolve-dots 1 2 '(30 40) .. 5)
;  '(1 2 30 40 5)
;  (resolve-dots 1 2 '() .. 5)
;  '(1 2 5)
;  (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
;  '(1 20 30 4 40 50 60 7)
;)
;;(dots?)

(check-all BINDINGS
  (defines?)
  (binds?)
  (predicates?)
  (cases?)
  (lambdas?)
  (lets?)
  (biglists?)
  )