;;;; File: bindings-test.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Feb 12, 2011

(require 'tests 'bindings)

(import tests bindings)

(define bindings-test
  (dispatcher #f
    (bind-set!
      (compare-with equal?
        (begin
          (bind-set! (stack (push! pop!))
            (list
              '()
              (list
                (lambda (xpr) (set! stack (cons xpr stack)))
                (lambda () (set! stack (cdr stack))))))
          (push! 1)
          (push! 0)
          stack)
        '(0 1)
        (begin
          (bind-set! (a (b . C)) '(1 (2 3 3)))
          (list a b C))
        '(1 2 (3 3))
        (begin
          (bind-define (plus5 times5) '(#f #f))
          (bind-set! (plus5 times5)
            (let ((a 5))
              (list
                (lambda (x) (+ x a))
                (lambda (x) (* x a)))))
          (list (plus5 6) (times5 6)))
        '(11 30)))
    (bind-define
      (compare-with equal?
        (begin
          (bind-define (stack push! pop!)
            (let ((lst '()))
              (list
                (lambda () lst)
                (lambda (xpr) (set! lst (cons xpr lst)))
                (lambda () (set! lst (cdr lst))))))
          (push! 0)
          (push! 1)
          (pop!)
          (stack))
        '(0)
        (begin
          (bind-define (plus5 times5)
            (let ((a 5))
              (list
                (lambda (x) (+ x a))
                (lambda (x) (* x a)))))
          (list (plus5 6) (times5 6)))
        '(11 30)))
    (bind
      (compare-with eqv?
        (bind a 1 a) 1)
      (compare-with equal?
        (bind (x y z w) '(1 2 3 4) (list x y z w))
        '(1 2 3 4)
        (bind (x . y) '(1 2 3 4) (list x y))
        '(1 (2 3 4))
        (bind (x (y (z)) w) '(1 (2 (3)) 4)
          (list x y z w))
        '(1 2 3 4)
        (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-flat
      (compare-with equal?
        (bind-flat () '() '())
        '()
        (bind-flat (a b) '(1 2) (list a b))
        '(1 2)
        (bind-flat (a . b) '(1 2) (list a b))
        '(1 (2))
        (bind-flat (a b) => symbol->string (list a b))
        (list "a" "b")))
    (bind-flat-let*
      (compare-with equal?
        (bind-flat-let* (((a b) => symbol->string) (c => symbol->string)) (list a b c))
        '("a" "b" "c")
        (bind-flat-let* (((a b) '(1 2)) (c a)) (list a b c))
        '(1 2 1)))
    (bind-lambda
      (compare-with equal?
        ((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*
      (compare-with 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))))
    (bind-loop
      (compare-with equal?
        (bind-loop proc (x (a . b) y) '(5 (1) 0)
          (if (zero? x)
            (list x a b y)
            (proc (sub1 x) (cons a (cons a b)) (add1 y))))
        '(0 1 (1 1 1 1 1) 5)
        (bind-loop proc (x y) '(5 0)
          (if (zero? x)
            (list x y)
            (proc (sub1 x) (add1 y))))
        '(0 5)))
    (bind-let
      (compare-with equal?
        (bind-let (((x y (z . w)) '(1 2 (3 4 5))))
          (list x y z w))
        '(1 2 3 (4 5))
        (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 loop (((a b) '(5 0)))
          (if (zero? a)
            (list a b)
            (loop (list (sub1 a) (add1 b)))))
        '(0 5)
        (bind-let loop (
          ((x . y) '(1 2 3))
          ((z) '(10))
          )
          (if (zero? z)
            (list x y z)
            (loop (cons (add1 x) (map add1 y)) (list (sub1 z)))))
        '(11 (12 13) 0)))
    (bind-let*
      (compare-with equal?
        (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
      (compare-with equal?
        (bindrec ((o?) e?)
          (list (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
      (compare-with equal?
        (bind-letrec (
          ((o? (e?))
           (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
                 (list (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
          )
          (list (o? 95) (e? 95)))
        '(#t #f)))
    (bind-matches?
      (compare-with eqv?
        (let ((two '(1 2)))
          (bind-matches? () two)) #f
        (bind-matches? () '()) #t
        (let ((two '(1 2)))
          (bind-matches? (a b) two (lambda () (even? (apply + two))))) #f
        (let ((two '(1 2)))
          (bind-matches? (a b) two (lambda () (odd? (apply + two))))) #t
        (let ((three '(1 2 3)))
          (bind-matches? (a b) three (lambda () (even? (apply + three))))) #f
        (bind-matches? (a (b C) . d) '(1 (2 3) . 4)) #t
        (bind-matches? (a (b C) . d) '(1 (2 3) 4 5)) #t
        (bind-matches? (a (b . C) d) '(1 (2 3) 4)) #t
        (bind-matches? (a (b . C) . d) '(1 2 3 4 5)) #f
        (bind-matches? (a (b C) d) '(1 (2 3) 4 5)) #f))
    (bind-case
      (compare-with =
        (let ((xpr '(2 0)))
          (bind-case xpr
            ((a b) (=> (lambda () (not (zero? (cadr xpr))))) (/ a b))
            ((a b) (* a b))))
        0)
      (compare-with equal?
        (bind-case '(1 2)
          (() '())
          ((a) (list a))
          ((a b) (list a b))
          ((a b C) (list a b C)))
        '(1 2)
        (letrec (
          (my-map
            (lambda (fn lst)
              (bind-case lst
                (() '())
                ((x . xs) (cons (fn x) (map fn xs))))))
          )
          (my-map add1 '(1 2 3)))
        '(2 3 4)))
    (bind-case-lambda
      (compare-with equal?
        (let ((xpr '(1 2 3 4 5)))
          ((bind-case-lambda
             ((a (b . C) . d) (list a b C d))
             ((e . f) (=> (lambda () (zero? (car xpr)))) e)
             ((e . f) (list e f)))
           xpr))
        '(1 (2 3 4 5))
        ((bind-case-lambda
           ((a (b . C) . d) (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*
      (compare-with 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))
        ((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))))
))