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

(require-library bindings tuples simple-tests)

(import bindings
        (except macro-helpers atom? flatten)
        (only tuples tuple tuple? tuple-length tuple-ref tuple-from-upto)
        (only chicken error)
        simple-tests)
(import-for-syntax
  (only bindings macro-rules with-gensyms once-only))


(compound-test (bindings)

  (define-test (helpers?)
    (check
      (equal? (flatten '(a (b c (d))))
              '(a b c d))
      (equal? (memp odd? '(2 4 3 1))
              '(3 1))
      (not (assp odd? '((0 1) (0 2) (0 3))))
      (equal? (assp odd? '((0 1) (1 2) (2 3)))
              '(1 2))
      (equal? (filter odd? '(2 4 3 6 1 0))
              '(3 1))
      (equal? (filter* odd? '(1 (2 (3 . 4) . 5) . 6))
              '(1 ((3) . 5)))
      (equal? (collect* (lambda (x) (and (number? x) (odd? x)))
                        '(1 (2 (3 . 4) . 5) . 6))
              '(1 3 5))
      (equal? (adjoin 'x '(a b c))
              '(x a b c))
      (equal? (adjoin 'x '(a b x c))
              '(a b x c))
      (equal? (remove-duplicates '(a b c b a d))
              '(a b c d))
      (eq? (strip-prefix 'x 'xabc) 'abc)
      (eq? (strip-suffix 'x 'abcx) 'abc)
      (eq? (add-prefix 'x 'abc) 'xabc)
      ((prefixed-with? 'x) 'xabc)
      (not ((prefixed-with? 'x) 'abc))
      (equal? (extract odd? '(1 2 (3 4 (5 6))))
              '(1 3 5))
      (equal? (extract (prefixed-with? 'x)
                       '(abc (xab yd (ya xb))))
              '(xab xb))
      (equal? (map* + '(1 (2 . 3) . 4) '(10 (20 . 30) . 40))
              '(11 (22 . 33) . 44))
      (equal? (flatten-map* + '(1 (2 . 3) . 4) '(10 (20 . 30) . 40))
              '(11 22 33 44))
      (equal?
        (replace* (lambda (x) (and (atom? x) (not (null?  x)) (odd? x)))
                  (lambda (x) (* 10 x))
                  '(0 (1 (2 . 3))))
        '(0 (10 (2 . 30))))
      (= (plist-tail '(0 1 2 . 3) 3) 3)
      (= (ptail '(0 1 2 . 3)) 3)
      (equal? (phead '(0 1 2 . 3)) '(0 1 2))
      (equal? (plist-head '(0 1 2 . 3) 3) '(0 1 2))
      (equal? (vector-tail '#(0 1 2 3) 4) '#())
      (equal? (vector-tail '#(0 1 2 3) 0) '#(0 1 2 3))
      (equal? (vector-head '#(0 1 2 3) 0) '#())
      (equal? (vector-head '#(0 1 2 3) 4) '#(0 1 2 3))
      (atom? '#(1))
      ((list-of atom?) '(#() #(1) #(0 1)))
      (not ((list-of) '#(a 1)))
      ((list-of number? positive?) '(1 2 3))
      (not ((list-of number? positive?) '(1 -2 3)))
      ))
  (helpers?) 

  (define-test (sequences?)
    (check
      "ADD TUPLES TO GENERIC SEQUENCES"
      (seq-length-ref-tail! tuple?
                            tuple-length
                            tuple-ref
                            tuple-from-upto)
      (equal? (bind (x y z) (tuple 1 2 3) (list x y z)) '(1 2 3))
      (equal? (bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) '(0 1 2))
      (equal? (bind (x (y (z))) (vector 0 (tuple 1 "2")) (list x y z))
              '(0 1 #\2))
      ))
  (sequences?)

  (define-test (bind?)
    (check
      (= (bind a 1 a) 1)
      (equal? (bind (a b) '(1 2) (where (odd? a)) (list a b)) '(1 2))
      (equal?
        (bind (x y z w) '(1 2 3 4) (list x y z w))
        '(1 2 3 4))
      (equal?
        (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 (z . u) . v) . w)
                '(1 (2 (3 4) 5) 6)
                (where (odd? z))
                (list x y z u v w))
              '(1 2 3 (4) (5) (6)))
      (condition-case
        (bind (x (y (z . u) . v) . w)
          '(1 (2 (3 4) 5) 6)
          (where (even? z))
          (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 (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) '(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) '#(5 0)
          (if (zero? x)
            (vector x y)
            (loop (vector (- x 1) (+ y 1)))))
        '#(0 5))
      ))
  (bind?)

  (define-test (predicate?)
    (check
      (not ((bindable? (x)) '(name 1)))
      (not ((bindable? (x y) (number? x)) '(name 1)))
      ((bindable? (_ x)) '(name 1))
      (not ((bindable? (_ x)) '(name 1 2)))
      (not ((bindable? (_ x y) (symbol? x)) '(name 1 2)))
      ((bindable? (a b) (odd? a)) '#(1 2))
      (not ((bindable? (x (y z)) (char-alphabetic? y)) '(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))
      ))
  (predicate?)

  (define-test (case?)
    (check
      (not (bind-case '#() (() #f)))
      (equal? (bind-case '#(2 2)
                ((a b) (where (even? a) (odd? b)) (print 'even-odd a b))
                ((a b) (where (odd? a) (even? b)) (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 (char-alphabetic? y)) (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 (char-alphabetic? y)) (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 (char-numeric? y)) (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 . 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 (list? 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 . 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? (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))
      (define (my-map fn vec)
        (bind-case vec
          (() '())
          ((x . xs) (cons (fn x)
                          (my-map fn xs)))))
      (equal? (my-map add1 '#(1 2 3)) '(2 3 4))
      "NON-SYMBOL LITERALS"
      (bind-case '#("a") ((#f) #f) (("a") #t))
      (equal? (bind-case '#(1 (#f 3))
                ((x y) (where (number? y)) (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 (#f 3))
                ((x ("y" . z)) (list x z))
                ((x (#f z)) (list x z)))
              '(1 3))
      ))
  (case?)

  (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 (zero? e)) f)
           ((e . f) (list e f)))
         '#(0 2 3 4 5))
        '#(2 3 4 5))
      (equal?
        ((bind-case-lambda
           ((e . f) (where (zero? e)) 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) (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)))
      ))
  (lambdas?)

  (define-test (lets?)
    (check
      (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* 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)))
          (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))
      ))
  (lets?)

  (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)) '(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 (push top pop)
            (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)
      ))
  (defines?)

  (define-test (macros?)
    (check
      (define-er-macro (efreeze . body)
        `(,%lambda () ,@body))
      (= ((efreeze 1 2 3)) 3)

      (define-er-macro (osquare (once x)) `(,%* ,x ,x))
      (= (let ((x 5)) (osquare ((lambda () (set! x (* x 10)) x))))
         2500)
      (define-er-macro (square x) `(,%* ,x ,x))
      (= (let ((x 5)) (square ((lambda () (set! x (* x 10)) x))))
         25000)
      (define-macro (foo (qux))
        (keywords bar baz)
        `(case ',qux
           ((bar baz) ',qux)
           (else 'no)))
      (eq? (foo (bar)) 'bar)
      (eq? (foo (baz)) 'baz)
      (eq? (foo (qux)) 'no)
      (define-macro (nif (once xpr) pos zer neg)
        `(cond
           ((positive? ,xpr) ,pos)
           ((negative? ,xpr) ,neg)
           (else ,zer)))
      (eq? (nif 2 'positive 'zero 'negative) 'positive)
      (define-macro (freeze xpr)
        `(lambda () ,xpr))
      (= ((freeze 5)) 5)
      (define-macro (swap! x y)
        `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
      (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
              '(y x))
      (= (let-er-macro (((freeze xpr) `(,%lambda () ,xpr)))
           ((freeze 3)))
         3)
      (= (letrec-er-macro (((second lst) `(,%car (,%rest ,lst)))
                           ((rest lst) `(,%cdr ,lst)))
          (second '(1 2 3)))
        2)
      (= (letrec-macro ((second (macro-rules ()
                                  ((_ lst) `(,car (rest ,lst)))))
                        (rest (macro-rules ()
                                ((_ lst) `(,cdr ,lst)))))
           (second '(1 2 3)))
         2)
      (letrec-macro ((odd? (macro-rules ()
                             ((_ n) `(if ,(zero? n) #f ,(even?
                                                              (- n 1))))))
                     (even? (macro-rules ()
                              ((_ n) `(if ,(zero? n) #t ,(odd? (- n 1)))))))
                    (even?  286))

      "LITERALS"
      (define-macro foo
        (macro-rules ()
          ((_ "foo" x) x)
          ((_ #f x) `(list 'false))
          ((_ #f x) 'false)
          ((_ a b) (where (string? a)) `(list ,a ,b))
          ((_ a b) (where (odd? a)) `(list ,a ,b))
          ((_ a b) a)))
      (= (foo "foo" 1) 1)
      (equal? (foo "bar" 2) '("bar" 2))
      (equal? (foo #f 'blabla) '(false))
      (equal? (foo 1 2) '(1 2))
      (= (foo 2 3) 2)

      "IN?"
      (define-macro (in? what equ? . choices)
        (let ((insym 'in))
          `(let ((,insym ,what))
             (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
                        choices)))))
      (in? 2 = 1 2 3)
      (not (in? 5 = 1 2 3))

      "VERBOSE IFS"
      (define-er-macro (verbose-if test (then . xprs) (else . yprs))
        (keywords then else)
        `(,%if ,test
           (,%begin ,@xprs)
           (,%begin ,@yprs)))
      (define (quux x)
        (verbose-if (odd? x) (then "odd") (else "even")))
      (equal? (quux 3) "odd")
      (equal? (quux 4) "even")
      (define-syntax-rule (sr-vif test (then . xprs) (else . yprs))
        (keywords then else)
        (if test
          (begin . xprs)
          (begin . yprs)))
      (eq? (sr-vif (odd? 5) (then 1 'odd) (else 2 'even)) 'odd)
      (eq? (sr-vif (odd? 6) (then 1 'odd) (else 2 'even)) 'even)
      (define-macro vif
        (macro-rules (then else)
          ((_ test (then xpr . xprs))
           `(if ,test
              (begin ,xpr ,@xprs)))
          ((_ test (else xpr . xprs))
           `(if ,(not test)
              (begin ,xpr ,@xprs)))
          ((_ test (then xpr . xprs) (else ypr . yprs))
           `(if ,test
              (begin ,xpr ,@xprs)
              (begin ,ypr ,@yprs)))))
      (define (oux)
        (vif #t (then 'true)))
      (define (pux)
        (vif #f (else 'false)))
      (eq? (oux) 'true)
      (eq? (pux) 'false)
      
      "LOW-LEVEL COND"
      (define-macro my-cond
        (macro-rules (else =>)
          ((_ (else xpr . xprs))
           `(begin ,xpr ,@xprs))
          ((_ (test => xpr))
           `(let ((tmp ,test))
              (if tmp (,xpr tmp))))
          ((_ (test => xpr) . clauses)
           `(let ((tmp ,test))
              (if tmp
                (,xpr tmp)
                (my-cond ,@clauses))))
          ((_ (test))
           `(,void))
          ((_ (test) . clauses)
           `(let ((tmp ,test))
              (if tmp
                tmp
                (my-cond ,@clauses))))
          ((_ (test xpr . xprs))
           `(if ,test (begin ,xpr ,@xprs)))
          ((_ (test xpr . xprs) . clauses)
           `(if ,test
              (begin ,xpr ,@xprs)
              (my-cond ,@clauses)))
          ))
      (my-cond ((> 3 2)))
      (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
           'greater)
      (eq? (my-cond ((> 3 3) 'greater)
               ((< 3 3) 'less)
               (else 'equal))
           'equal)
      (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
               (else #f))
         2)
      (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
               (else #f)))

      "LETREC"
      (define-macro (my-letrec pairs . body)
        (let ((vars (map car pairs))
              (vals (map cadr pairs))
              (aux (map (lambda (x) (gensym)) pairs)))
          `(let ,(map (lambda (var) `(,var #f)) vars)
             (let ,(map (lambda (a v) `(,a ,v)) aux vals)
               ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
               ,@body))))
      (equal?
        (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
                    (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
                   (list (o? 95) (e? 95)))
        '(#t #f))

      "ANAPHORIC MACROS"
      (define-macro (alambda args xpr . xprs)
        (inject self)
        `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
           ,self))
      (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
      (= (! 5) 120)
      (define-macro aif
        (macro-rules it ()
          ((_ test consequent)
           `(let ((,it ,test))
              (if ,it ,consequent)))
          ((_ test consequent alternative)
           `(let ((,it ,test))
              (if ,it ,consequent ,alternative)))))
      (define (mist x) (aif (! x) it))
      (= (mist 5) 120)
      ))
  (macros?)

  (define-test (etc?)
    (check
      (define-syntax-rule (freeze x) (lambda () x))
      (= ((freeze 25)) 25)
      (define-macro (square x)
        (once-only (x)
          `(* ,x ,x)))
      (let ((n 4))
        (= (square (begin (set! n (+ n 1)) n)) 25))

      (define-macro (for (var start end) . body)
        (once-only (start end)
          `(do ((,var ,start (add1 ,var)))
                 ((= ,var ,end))
                 ,@body)))
      (define counter
        (let ((state 0))
          (lambda ()
            (set! state (+ state 1))
            state)))
      (let ((lst '()))
        (for (x 0 (counter)) (set! lst (cons x lst)))
        (equal? lst '(0)))
      (define-macro (times a b)
        (with-gensyms (x y)
          `(let ((,x ,a) (,y ,b))
             (* ,x ,y))))
      (= (times 3 5) 15)))
  (etc?)
  )