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

(require-library bindings arrays basic-sequences simple-tests
                 simple-exceptions)

(import simple-tests
        bindings basic-sequences simple-exceptions
        ;(only basic-sequences seq-db)
        (only arrays array array? array-ref array-tail array->list)
        )

(define-test (binds?)
  (check
    (= (bind a 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"
    (seq-db array? ref: array-ref tail: array-tail maker: array ra?: #t)
    (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?)
  (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)))
    ((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?)
  (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? (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?)
  (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?
      ((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?)
  (check
    (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?)
  (check
    (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))
    ))

(define-test (types?)
  (check
    "LISTS AS ALGEBRAIC TYPE"
    (define-algebraic-type LIST List? (Nil) (Cons (x) (xs List?)))
    (define (List->list lst)
      (bind-case (<< lst List?)
        ((#:Nil) '())
        ((#:Cons x xs)
         (cons x (List->list xs)))))
    (define three (Cons 0 (Cons 1 (Cons 2 (Nil)))))
    (equal? (List->list three) '(0 1 2))
    
    "TYPED VECTORS AS ALGEBRAIC TYPE"
    (define-algebraic-type VEC Vec? (Vec (x integer?) xs integer?))
    (define (Vec->list vec)
      (bind (#:Vec x . xs) (<< vec Vec?)
        (cons x (vector->list (subvector xs 1)))))
    (define four (Vec 0 1 2 3))
    (equal? (Vec->list four) '(0 1 2 3))

    "TYPED TREES AS ALGEBRAIC TYPE"
    (define-algebraic-type TREE Tree?
      (Leaf (b number?))
      (Node (left Tree?) (t number?) (right Tree?)))
    (define (leaf-sum tr)
      (bind-case (<< tr Tree?)
        ((#:Leaf b) b)
        ((#:Node left middle right)
         (+ (leaf-sum left) middle (leaf-sum right)))))
    (define tree (Node (Leaf 1) 2 (Leaf 3)))
    (= (leaf-sum tree) 6)
    ))


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