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

(import simple-tests
        bindings
        simple-exceptions
        (chicken base)
        ;(only arrays array array? array-ref array-tail array->list)
        )

  (define (my-map fn lst)
    (let loop ((lst lst) (result '()))
      (bind-case lst
        (() (reverse result))
        ((x . xs)
         (loop xs (cons (fn x) result))))))

  (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)))))))

  (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)))))))

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

(define-test (binds?)
  (= (bind a 1 a) 1)
	(= (bind (a ()) (list 1 "") a) 1) 
  (equal? (bind (a b) '(1 2) (where (a odd?)) (list a b)) '(1 2))
  (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?
    (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-named loop (x (a . b) y) '(5 #(1) 0) (where (x integer?))
      (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-named loop (x y) #(5 0) (where (x integer?))
      (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 sequence) #f)))
  (bind #f #f #t)
  (not
    (condition-case
      (bind #f #t #t)
      ((exn sequence) #f)))
  (not
    (condition-case
      (bind (x . #f) '(1 . #t) x)
      ((exn sequence) #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 sequence) #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 sequence) #f)))
  (not
    (condition-case
      (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y))
      ((exn sequence) #f)))
  (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z))

;  "ADD ARRAYS TO GENERIC SEQUENCES"
;  (bind-seq-db array? ref: array-ref tail: array-tail)
;  (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 (predicates?)
  (not ((bindable? (x)) '(name 1)))
  (not ((bindable? (x y) (where (x number?))) '(name 1)))
  ((bindable? (_ x)) '(name 1))
  (not ((bindable? (_ x)) '(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 (cases?)
  (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? (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? (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 . 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 '()))
      (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?)
  (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?
    ((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?
    ((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 sequence) #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?)
  (equal?
    (bind-let (
               (((x y) z) '(#(1 2) 3))
               (u (+ 2 2))
               ((v w) #(5 6))
               )
      (where (u integer?))
      (list x y z u v w))
    '(1 2 3 4 5 6))
  (equal?
    (bind-named loop (a b) '(5 0)
      (if (zero? a)
        (list a b)
        (loop (list (- a 1) (+ b 1)))))
    '(0 5))
  (equal?
    (bind-let loop (
                    ((a b) '(5 0))
                    )
      (where (a integer?))
      (if (zero? a)
        (list a b)
        (loop (list (- a 1) (+ b 1)))))
    '(0 5))
  (equal?
    (bind-let loop (
                    ((x . y) '(1 2 3))
                    ((z) #(10))
                    )
      (where (x integer?) (y (list-of? integer?)) (z integer?))
      (if (zero? z)
        (list x y z)
        (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
    '(11 (12 13) 0))
  (equal?
    (bind-let* (
                (((x y) z) '(#(1 2) 3))
                (u (+ 1 2 x))
                ((v w) (list (+ z 2) 6))
                )
      (where (u integer?))
      (list x y z u v w))
    '(1 2 3 4 5 6))
  (equal?
    (bindrec ((o?) e?)
      (vector
        (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
        (lambda (n) (if (zero? n) #t (o? (- n 1)))))
      (where (o? procedure?) (e? procedure?))
      (list (o? 95) (e? 95)))
    '(#t #f))
  (equal?
    (bind-letrec (
                  ((o? (e?))
                   (list
                     (lambda (m) (if (zero? m) #f (e? (- m 1))))
                     (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
                  )
      (where (o? procedure?) (e? procedure?))
      (list (o? 95) (e? 95)))
    '(#t #f))
  )

(define-test (defines?)
  (equal?
    (let ((x #f) (y #f) (z #f))
      (bind-set! (x (y . z))
        '(1 #(2 3 3)))
      (list x y z))
    '(1 2 #(3 3)))
  (equal?
    (let ((x #f) (y #f) (z #f))
      (bind-set! (x #f _ (y _ . z))
        '(1 #f 10 #(2 30 3 3)))
      (list x y z))
    '(1 2 #(3 3)))
  (equal?
    (let ((x #f) (y #f) (z #f))
      (bind-set! x 1 y 2 z 3)
      (list x y z))
    '(1 2 3))
  (equal?
    (let ((x #f) (y #f) (z #f) (u #f) (v #f))
      (bind-set!
        (x (y . z))
        '(1 #(2 3 3))
        (u (v))
        '(10 (20))
        (where (x integer?) (u number?)))
      (list x y z u v))
    '(1 2 #(3 3) 10 20))
  (equal?
    (let ((x #f) (y #f) (z #f))
      (bind-set! (x (y . z))
        '(1 #(2 3 3))
        (where (x integer?)))
      (list x y z))
    '(1 2 #(3 3)))
  (equal?
    (begin
      '(define stack #f) '(define push! #f) '(define pop! #f)
      (bind-set! (stack (push! pop!))
        (list
          '()
          (vector
            (lambda (xpr) (set! stack (cons xpr stack)))
            (lambda () (set! stack (cdr stack)))))
        (where (push! procedure?) (pop! procedure?)))
      (push! 1)
      (push! 0)
      stack)
    '(0 1))
  (equal?
    (begin
      (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 (x . y) '(1 . 2) ((z)) '((3)) (where (x integer?)))
      (list x y z))
    '(1 2 3))
  (equal?
    (begin
      (bind-define (x _ . y) '(1 10 . 2) ((z)) '((3)) (where (x integer?)))
      (list x y z))
    '(1 2 3))
  (equal?
    (begin
      (bind-define (x #f . y) '(1 #f . 2) ((z)) '((3)))
      (list x y z))
    '(1 2 3))
  (equal?
    (begin
      (bind-define x 1 y 2 z 3 (where (x integer?)))
      (list x y z))
    '(1 2 3))
  (equal?
    (begin
      (bind-define (push top pop)
        (let ((lst '()))
          (vector
            (lambda (xpr) (set! lst (cons xpr lst)))
            (lambda () (car lst))
            (lambda () (set! lst (cdr lst)))))
        (where (push procedure?)
               (top procedure?)
               (pop procedure?)))
      (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)))
        (list 1 (vector (odd? 2) 3 (list 4 (odd?  5))))
        (where (x integer?)))
      (list x y z))
    '(1 3 4))
  )

(compound-test (BINDINGS)
  (binds?)
  (predicates?)
  (cases?)
  (lambdas?)
  (lets?)
  (defines?)
  )