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

(require-library bindings arrays simple-tests)

(import simple-tests
        bindings
        (prefix list-bindings list-)
        (only arrays array array? array-length array-item array-drop
              array->list)
        )

(define-test (bind?)
  (check
    (= (bind a 1 a) 1)
    (equal? (bind (a b) (where (a odd?)) '(1 2) (list a b)) '(1 2))
    (equal?
      (list-bind (x y z w) '(1 2 3 4) (list x y z w))
      '(1 2 3 4))
    (equal?
      (list-bind (_ y z _) '(1 2 3 4) (list y z))
      '(2 3))
    (equal?
      (bind (x . y) '#(1 2 3 4) (list x y))
      '(1 #(2 3 4)))
    (equal?
      (bind (_ . y) '#(1 2 3 4) y)
      '#(2 3 4))
    (equal?
      (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
        (list x y z u v w))
      '(1 2 #\f #\o "o" 4))
    (equal?
      (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4)
        (list x y z u w))
      '(1 2 #\f #\o 4))
    (equal?
      (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y))
      '(1 2))
    (equal?
      (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y))
      '(1 2))
    (equal? (list-bind (x (y (z . u) . v) . w)
              (where (z odd?))
              '(1 (2 (3 4) 5) 6)
              (list x y z u v w))
            '(1 2 3 (4) (5) (6)))
    (condition-case
      (list-bind (x (y (z . u) . v) . w)
        (where (z even?))
        '(1 (2 (3 4) 5) 6)
        (list x y z u v w))
      ((exn bind) #t))
    (equal?
      (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)))
    (equal?
      (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)))
    (equal?
      (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)))
    (equal?
      (bind* loop (x (a . b) y) (where (x integer?)) '(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))
    (equal?
      (bind* loop (x y) (where (x integer?)) #(5 0)
        (if (zero? x)
          (vector x y)
          (loop (vector (- x 1) (+ y 1)))))
      '#(0 5))
    "LITERALS"
    (equal? 
      (bind (#f . ys) '(#f 2 3) ys)
      '(2 3))
    (not
      (condition-case
        (bind (#f . ys) '(#t 2 3) ys)
        ((exn bind) #f)))
    (bind #f #f #t)
    (not
      (condition-case
        (bind #f #t #t)
        ((exn bind) #f)))
    (= (list-bind (x . #f) '(1 . #f) x) 1)
    (not
      (condition-case
        (bind (x . #f) '(1 . #t) x)
        ((exn bind) #f)))
    (equal?
      (bind (x (y . #f)) '(1 (2 . #f)) (list x y))
      '(1 2))
    (not
      (condition-case
        (bind (x (y . #f)) '(1 (2 . #t)) (list x y))
        ((exn bind) #f)))
    (equal?
      (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y))
      '(1 2))
    (not
      (condition-case
        (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y))
        ((exn bind) #f)))
    (not
      (condition-case
        (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
        ((exn bind) #f)))
    (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))

    "ADD ARRAYS TO GENERIC SEQUENCES"
    (bind-table-add!  array?
                      array-length
                      (lambda (seq k)
                        (array-item k seq))
                      (lambda (seq k)
                        (array-drop k seq)))
    (equal?
      (bind (x y z) (array 1 2 3) (list x y z))
      '(1 2 3))
    (equal?
      (bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
      '(0 1 2))
    (equal?
      (bind (x (y . z)) (vector 0 (array 1 2 3 4))
        (list x y (array->list z)))
      '(0 1 (2 3 4)))

    ))

(define-test (predicate?)
  (check
    (not ((bindable? (x)) '(name 1)))
    (not ((bindable? (x y) (where (x number?))) '(name 1)))
    ((bindable? (_ x)) '(name 1))
    (not ((bindable? (_ x)) '(name 1 2)))
    (not ((list-bindable? (_ x y) (where (x symbol?))) '(name 1 2)))
    ((bindable? (a b) (where (a odd?))) '#(1 2))
    (not ((bindable? (x (y z)) (where (y char-alphabetic?))) '(1 "23")))
    ((bindable? (x (y . z))) '(1 "23"))
    ((bindable? (x y)) '(1 "23"))
    (not ((bindable? (a (b . C) . d)) '(1 2 3 4 5)))
    (not ((bindable? (a)) 1))
    ))

(define-test (case?)
  (check
    (not (bind-case '#() (() #f)))
    (equal? (bind-case '#(2 2)
              ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
              ((a b) (where (a odd?) (b even?)) (print 'odd-even a b))
              ((a b) (list a b))) '(2 2))
    (equal? (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"))
    (equal? (bind-case '(1 "23")
              ((x (y z)) (where (y char-alphabetic?)) (list x y z))
              ((x (y . z)) (list x y z))
              ((x y) (list x y)))
            '(1 #\2 "3"))
    (equal? (bind-case '(1 "23")
              ((x (y z)) (where (y char-alphabetic?)) (list x y z))
              ((x (y . _)) (list x y))
              ((x y) (list x y)))
            '(1 #\2))
    (equal? (bind-case '(1 "23")
              ((x (y z)) (where (y char-numeric?)) (list x y z))
              ((x (y . z)) (list x y z))
              ((x y) (list x y)))
            '(1 #\2 #\3))
    (equal? (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))
    (equal? (list-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))
    (equal? (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"))
    (equal? (bind-case '(1 #(2 3))
              ((x y) (where (y list?)) (list x y))
              ((x (y . z)) (list x y z))
              ((x (y z)) (list x y z)))
            '(1 2 #(3)))
    (equal? (list-bind-case '(1 (2 3))
              ((x (y . z)) (list x y z))
              ((x y) (list x y))
              ((x (y z)) (list x y z)))
            '(1 2 (3)))
    (equal? (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)))
    (equal? (list-bind-case '(1 (2 . 3))
              ((x (y . z)) (list x y z))
              ((x (y z)) (list x y z)))
            '(1 2 3))
    (equal? (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)))
    (equal?
      (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"
    (define (my-map fn lst)
      (let loop ((lst lst) (result '()))
        (list-bind-case lst
          (() (reverse result))
          ((x . xs)
           (loop xs (cons (fn x) result))))))
    (equal? (my-map add1 '(0 1 2 3)) '(1 2 3 4))
    (define (vector-map 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)))))))
    (equal? (vector-map add1 #(0 1 2 3)) #(1 2 3 4))
    (define (vector-reverse 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)))))))
    (equal? (vector-reverse #(0 1 2 3)) #(3 2 1 0))

    "NON-SYMBOL LITERALS"
    (bind-case #("a") ((#f) #f) (("a") #t))
    (equal? (bind-case (vector 1 (list (odd? 2) 3))
              ((x y) (where (y number?)) (list x y))
              ((x ("y" . z)) (list x z))
              ((x (#f z)) (list x z)))
            '(1 3))
    (equal? (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)))
    (equal? (bind-case #(1 ("y" 3))
              ((x ("y" . z)) (list x z))
              ((x (#f z)) (list x z)))
            '(1 (3)))
    ))

(define-test (lambdas?)
  (check
    (equal?
      ((bind-lambda (a (b . C) . d)
         (list a b C d))
       '(1 #(20 30 40) 2 3))
      '(1 20 #(30 40) (2 3)))
    (equal?
      ((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)))
    (equal?
      ((bind-case-lambda
         ((e . f) (where (e zero?)) f)
         ((e . f) (list e f)))
       '#(0 2 3 4 5))
      '#(2 3 4 5))
    (equal?
      ((list-bind-case-lambda
         ((e . f) (where (e zero?)) e)
         ((a (b . #f) . d) (list a b d))
         ((e . f) (list e f)))
       '(1 (2 . #f) 4 5))
      '(1 2 (4 5)))
    (equal?
      ((list-bind-case-lambda
         ((e . f) (where (e zero?)) 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)))
    (not (condition-case
           ((bind-case-lambda
              ((e . f) (where (e zero?)) e)
              ((a (b . #f) . d) (list a b d)))
            '(1 (2 . #t) 4 5))
           ((exn bind) #f)))
    (equal?
      ((bind-case-lambda
         ((e . f) (where (e zero?)) e)
         ((a (b "c") . d) (list a b d))
         ((e . f) (list e f)))
       '(1 (2 "c") 4 5))
      '(1 2 (4 5)))
    (equal?
      ((bind-case-lambda
         ((a (b . C) . d) (where (a integer?)) (list a b C d))
         ((e . f) (list e f)))
       '(1 #(2 3 4) 5 6))
      '(1 2 #(3 4) (5 6)))
    (equal?
      ((bind-case-lambda
         ((a (b . C) . d) (where (a string?)) (list a b C d))
         ((e . f) (list e f)))
       '(1 #(2 3 4) 5 6))
      '(1 (#(2 3 4) 5 6)))
    (equal?
      ((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)))
    (equal?
      ((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)))
    ))

(define-test (lets?)
  (check
    (equal?
      (bind-let (
        ((x y (z . w)) (where (x number?)) '(1 2 #(3 4 5)))
        )
        (list x y z w))
      '(1 2 3 #(4 5)))
    (equal?
      (bind-let (
        (((x y) z) '(#(1 2) 3))
        (u (where (u integer?)) (+ 2 2))
        ((v w) '#(5 6))
        )
        (list x y z u v w))
      '(1 2 3 4 5 6))
    (equal?
      (bind* loop (a b) '(5 0)
        (if (zero? a)
          (list a b)
          (loop (list (- a 1) (+ b 1)))))
      '(0 5))
    (equal?
      (list-bind-let loop (
        ((a b) (where (a integer?))'(5 0))
        )
        (if (zero? a)
          (list a b)
          (loop (list (list (- a 1) (+ b 1))))))
      '(0 5))
    (equal?
      (bind-let loop (
        ((x . y) (where (x integer?) (y (list-of integer?))) '(1 2 3))
        ((z) (where (z integer?)) #(10))
        )
        (if (zero? z)
          (list x y z)
          (loop (list (cons (+ x 1) (map add1 y)) (list (- z 1))))))
      '(11 (12 13) 0))
    (equal?
      (bind-let* (
        (((x y) z) '(#(1 2) 3))
        (u (where (u integer?)) (+ 1 2 x))
        ((v w) (list (+ z 2) 6))
        )
        (list x y z u v w))
      '(1 2 3 4 5 6))
    (equal?
      (bindrec ((o?) e?) (where (o? procedure?) (e? procedure?))
        (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))
    (equal?
      (bind-letrec (
        ((o? (e?))
         (where (o? procedure?) (e? procedure?))
         (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
               (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
        )
        (list (o? 95) (e? 95)))
      '(#t #f))
    ))

(define-test (defines?)
  (check
    (equal?
      (let ((stack #f) (push! #f) (pop! #f))
        (bind-set! (stack (push! pop!))
          (list
            '()
            (vector
              (lambda (xpr) (set! stack (cons xpr stack)))
              (lambda () (set! stack (cdr stack))))))
        (push! 1)
        (push! 0)
        stack)
      '(0 1))
    (equal?
      (let ((x #f) (y #f) (z #f))
        (bind-set! (x (y . z))
          (where (x integer?))
          '(1 #(2 3 3)))
        (list x y z))
      '(1 2 #(3 3)))
    (equal?
      (begin
        (list-bind-define (plus5 times5)
          (let ((a 5))
            (list
              (lambda (x) (+ x a))
              (lambda (x) (* x a)))))
        (list (plus5 6) (times5 6)))
      '(11 30))
    (equal?
      (begin
        (bind-define (push top pop)
          (where (push procedure?)
                 (top procedure?)
                 (pop procedure?))
          (let ((lst '()))
            (vector
              (lambda (xpr) (set! lst (cons xpr lst)))
              (lambda () (car lst))
              (lambda () (set! lst (cdr lst))))))
        (push 0)
        (push 1)
        (pop)
        (top))
      0)
    (equal?
      (begin
        (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5))))
        (list x y z))
      '(1 3 4))
    (equal?
      (begin
        (bind-define (x (#f y (z #t)))
          (where (x integer?))
          (list 1 (vector (odd? 2) 3 (list 4 (odd?  5)))))
        (list x y z))
      '(1 3 4))
    ))

(compound-test (BINDINGS)
  (bind?)
  (predicate?)
  (case?)
  (lambdas?)
  (lets?)
  (defines?)
  )