;;;; File: bindings-run.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Mar 07, 2011
;;;;       Aug 02, 2011
;;;;       Sep 01, 2011

(require 'bindings)

(use bindings)

;;; (run xpr0 xpr1 ...)
;;; -------------------
(define (run . xprs)
  (let loop ((xprs xprs))
    (if (null? xprs)
      (print "All tests passed!")
      (if (car xprs)
        (loop (cdr xprs))
        (error 'run "#### Some test failed! ####")))))

(run
  (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)) '(1 #(2 3 3)))
      (list x y z))
    '(1 2 #(3 3)))
  (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 (top push! pop!)
        (let ((lst '()))
          (vector
            (lambda () (car lst))
            (lambda (xpr) (set! lst (cons xpr lst)))
            (lambda () (set! lst (cdr lst))))))
      (push! 0)
      (push! 1)
      (pop!)
      (top))
    0)
  (eqv?
    (bind a 1 a) 1)
  (equal?
    (bind (x y z w) '(1 2 3 4) (list x y z w))
    '(1 2 3 4))
  (equal?
    (bind (x . y) '#(1 2 3 4) (list x y))
    '(1 #(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)) v . w) (vector 1 (list 2 (cons 3 4)) 5 6)
      (list x y z u v w))
    '(1 2 3 4 5 #(6)))
  (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-loop proc (x (a . b) y) '(5 #(1) 0)
      (if (zero? x)
        (list x a b y)
        (proc (list (- x 1) (cons a (cons a b)) (+ y 1)))))
    '(0 1 (1 1 1 1 1 . #()) 5))
  (equal?
    (bind-loop proc (x y) '(5 0)
      (if (zero? x)
        (vector x y)
        (proc (vector (- x 1) (+ y 1)))))
    '#(0 5))
  (equal?
    (bind-let (((x y (z . w)) '(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 (+ 2 2))
      ((v w) '#(5 6))
      )
      (list x y z u v w))
    '(1 2 3 4 5 6))
  (equal?
    (bind-let loop (((a b) '(5 0)))
      (if (zero? a)
        (list a b)
        (loop (list (list (- a 1) (+ b 1))))))
    '(0 5))
  (equal?
    (bind-let loop (
      ((x . y) '(1 2 3))
      ((z) '#(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 (+ 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?)
      (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?))
       (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))
  (eqv?
    (let ((two '(1 2)))
      (bind-matches? two ())) #f)
  (eqv?
    (bind-matches? '() ()) #t)
  (eqv?
    (bind-matches? '(1 (2 3) . 4) (a (b C) . d)) #t)
  (eqv?
    (bind-matches? '(1 #(2 3) 4 5) (a (b C) . d)) #t)
  (eqv?
    (bind-matches? '(1 (2 3) 4) (a (b . C) . d)) #t)
  (eqv?
    (bind-matches? '#(1 2 3 4 5) (a (b . C) . d)) #f)
  (eqv?
    (bind-matches? '(1 (2 3) 4 5) (a (b C) d)) #f)
  (equal?
    (bind-case '#(1 2)
      (() '())
      ((a) (list a))
      ((a b) (list a b))
      ((a b C) (list a b C)))
    '(1 2))
  (equal?
    (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))
  (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)))
  (equal?
    (let ((xpr '#(0 2 3 4 5)))
      ((bind-case-lambda
         ((e . f) => (lambda () (zero? (vector-ref xpr 0))) f)
         ((e . f) (list e f)))
       xpr))
    '#(2 3 4 5))
  (equal?
    ((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)))
  (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)))
  )