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

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

(define-checks (listify? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  (bind-listify* "x")
  (cons string-car string-cdr)
  (bind-listify* 'a 1)
  '(1)
  (bind-listify* '(a . as) #(1 2 3))
  '(1 #(2 3))
  (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))
  '(1 (2) 3)
  (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))
  '(1 (2 (3 (300)) 4) #(50))
  (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))
  '(1 (30) 5)
  (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))
  '(1 (30) (5))
  (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))
  '(1 (30) (5))
  (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))
  '(1 (#\y) (5))
  (bind-listify* '(x) "x")
  '(#\x)
  (bind-listify* '(x . y) "xyz")
  '(#\x "yz")
  (bind-listify* 'x 1)
  '(1)
  (bind-listify* '(x) #(1))
  '(1)
  (bind-listify* '(x . y) #(1 2 3))
  '(1 #(2 3))
  (bind-listify* '(#f ()) #(#f #()))
  '(())
  )
;(listify?)

(define-checks (lists-only? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         #t)
  #t
  ;; this would work with string support:
  (condition-case (bind (x) "x" x)
    ((exn) #f))
  #f
  (bind-list (a b) '(1 2) (list a b))
  '(1 2)
  (bind-list* (x (y (z))) '(1 (2 (3))) (list x y z))
  '(1 2 3)
  (let ((x #f) (y #f))
    (bind-list (x y) '(1 2))
    (and (= x 1) (= y 2)))
  #t
  (let ((x #f) (y #f))
    (bind-list* (x (y)) '(1 (2)))
    (and (= x 1) (= y 2)))
  #t
  (let ((lst '()))
    (bind-list (push top pop)
      (list
        (lambda (xpr) (set! lst (cons xpr lst)))
        (lambda () (car lst))
        (lambda () (set! lst (cdr lst))))
      (push 0)
      (push 1)
      (pop)
      (top)))
  0
  (let ()
    (bind-list! (u v w))
    (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))
  #t
  )
;(lists-only?)

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

(define-checks (defines? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  (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?)

(define-checks (binds? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  (bind a 1 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-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?)
;
(define-checks (predicates? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  ((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
  )
;(predicates?)

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

(define-checks (cases? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  (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)) (list x y z))
    ((x (y . z)) (list x y z))
    ((x y) (list x y)))
  '(1 #\2 " 3")
  (bind-case '(1 "23")
    ((x (y z)) (where (char-alphabetic? y)) (list x y z))
    ((x (y . z)) (list x y z))
    ((x y) (list x y)))
  '(1 #\2 "3")
  (bind-case '(1 "23")
    ((x (y z)) (where (char-alphabetic? y)) (list x y z))
    ((x (y . _)) (list x y))
    ((x y) (list x y)))
  '(1 #\2)
  (bind-case '(1 "23")
    ((x (y z)) (where (char-numeric? y)) (list x y z))
    ((x (y . z)) (list x y z))
    ((x y) (list x y)))
  '(1 #\2 #\3)
  (bind-case '(1 "23")
    ((x (y z)) (list x y z))
    ((x (y . z)) (list x y z))
    ((x y) (list x y)))
  '(1 #\2 #\3)
  (bind-case '(1 "2 3") ;
    ((x (y . z)) (list x y z))
    ((x (y z)) (list x y z))
    ((x y) (list x y)))
  '(1 #\2 " 3")
  (bind-case '(1 #(2 3))
    ((x y) (where (list? y)) (list x y))
    ((x (y . z)) (list x y z))
    ((x (y z)) (list x y z)))
  '(1 2 #(3))
  (bind-case '(1 (2 3))
    ((x y) (list x y))
    ((x (y . z)) (list x y z))
    ((x (y z)) (list x y z)))
  '(1 (2 3))
  (bind-case '(1 (2 . 3))
    ((x y) (list x y))
    ((x (y . z)) (list x y z))
    ((x (y z)) (list x y z)))
  '(1 (2 . 3))
  (bind-case '#(1 2)
    (() '())
    ((a) (list a))
    ((a b) (list a b))
    ((a b c) (list a b c)))
  '(1 2)

  ;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)) (list x y))
    ((x ("y" . z)) (list x z))
    ((x (#f z)) (list x z)))
  '(1 3)
  (bind-case '(1 (#f 3))
    ((x y) (list x y))
    ((x ("y" . z)) (list x z))
    ((x (#f z)) (list x z)))
  '(1 (#f 3))
  (bind-case #(1 ("y" 3))
    ((x ("y" . z)) (list x z))
    ((x (#f z)) (list x z)))
  '(1 (3))
  )
;(cases?)

(define-checks (lambdas? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  ((bind-lambda (a (b . c) . d)
     (list a b c d))
   '(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)) e)
     ((a (b . #f) . d) (list a b d))
     ((e . f) (list e f)))
   '(1 (2 . #f) 4 5))
  '(1 2 (4 5))
  ((bind-case-lambda
     ((e . f) (where (zero? e)) e)
     ((a (b . #f) . d) (list a b d))
     ((e . f) (list e f))) ; match
   '(1 (2 . #t) 4 5))
  '(1 ((2 . #t) 4 5))
  (condition-case
    ((bind-case-lambda
       ((e . f) (where (zero? e)) e)
       ((a (b . #f) . d) (list a b d)))
     '(1 (2 . #t) 4 5))
    ((exn) #f))
    #f
  ((bind-case-lambda
     ((e . f) (where (zero? e)) e)
     ((a (b "c") . d) (list a b d))
     ((e . f) (list e 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)) (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) (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?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add support for vectors and strings
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* string? string-car string-cdr)
         #t)
  #t
  (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* 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?)

(import biglists)
;
(define (integers-from n)
  (Cons n (integers-from (+ n 1)) #f))
(define integers (integers-from 0))
(define (Car xs) (At 0 xs))
(define (Cdr xs) (Drop 1 xs))

(define-checks (biglists? verbose?)
  (begin ;; reset internal database
         (bind-listify*)
         ;; add vector and biglist support
         (bind-listify* vector? vector-car vector-cdr)
         (bind-listify* BigList? Car Cdr)
         #t)
  #t
  (bind (x y . zs) integers (Car zs))
  2
  (bind (_ _ . zs) integers (Car zs))
  2
  (bind (x #f (_ (b . cs) . zs))
        (vector 1 #f (List 10 integers 2 3))
        (list x b (Car cs) (Car zs) (At 1 zs)))
  '(1 0 1 2 3)
  )
;(biglists?)

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