(import scheme (chicken base)
        procedural-macros
        simple-tests)
(import-for-syntax (only procedural-macros
                         with-mapped-symbols
                         macro-rules
                         once-only)
                   (only (chicken base) list-of?)
                   (only bindings bind bind-case)
                   )

(define Counter
  (let ((n 0))
    (lambda ()
      (set! n (add1 n))
      n)))

(define-er-macro (Square form % compare?)
  (let ((x (cadr form)))
    (once-only (x)
      `(* ,x ,x))))

(define-er-macro-transformer (Swap! form rename compare?)
  (let ((x (cadr form)) (y (caddr form)))
    (with-mapped-symbols rename % (%tmp %let %set!)
      `(,%let ((,%tmp ,x))
         (,%set! ,x ,y)
         (,%set! ,y ,%tmp)))))

(define-er-macro (Nif form % compare?)
  (bind (_ xpr pos zer neg)
    form
    `(,%let ((,%result ,xpr))
            (,%cond
              ((,%positive? ,%result) ,pos)
              ((,%negative? ,%result) ,neg)
              (,%else ,zer)))))

(define-ir-macro (Vif form % compare?)
  (bind-case form
    ((_ test (key xpr . xprs))
     (cond
       ((compare? key %then)
        `(if ,test (begin ,xpr ,@xprs)))
       ((compare? key %else)
        `(if ,(not test) (begin ,xpr ,@xprs)))
       (else
         `(error 'Vif "syntax-error"))))
    ((_ test (key1 xpr . xprs) (key2 ypr . yprs))
     (cond
       ((and (compare? key1 %then)
             (compare? key2 %else))
       `(if ,test
          (begin ,xpr ,@xprs)
          (begin ,ypr ,@yprs)))
       ((and (compare? key1 %else)
             (compare? key2 %then))
       `(if ,test
          (begin ,ypr ,@yprs)
          (begin ,xpr ,@xprs)))
       (else
         `(error 'Vif "syntax-error"))))
    ))

(define-ir-macro (Alambda form % compare?)
  (bind (_ args xpr . xprs) form
    `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
       ,%self)))

(define-test (basic-macros?)
  (= (Square (Counter)) 1)
  (= (Square (Counter)) 4)
  (= (Square (Counter)) 9)

  (equal? (let ((x 'x) (y 'y))
            (Swap! x y)
            (list x y))
          '(y x))

  (eq? (Nif 5 'pos 'zer 'neg) 'pos)

  ;;; verbose if
  (eq? (Vif (positive? 5) (then 'pos)) 'pos)

  (equal?
    (map (Alambda (n)
           (if (zero? n)
             1
             (* n (self (- n 1)))))
         '(1 2 3 4 5))
    '(1 2 6 24 120))
  )

(define-macro (swap! x y)
  `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))

(define-macro (nif xpr pos zer neg)
  `(cond
     ((positive? ,xpr) ,pos)
     ((negative? ,xpr) ,neg)
     (else ,zer)))

(define-macro (freeze xpr)
  `(lambda () ,xpr))

(define-syntax foo
  (macro-rules ()
    ((_ "foo" x) x)
    ((_ #f x) `(list 'false))
    ((_ #f x) 'false)
    ((_ a b) (where (a string?))
             `(list ,a ,b))
    ((_ a b) (where (a odd?))
             `(list ,a ,b))
    ((_ a b) a)))

(define-macro (bar #() x)
  (where (x integer?))
  x)

(define-macro (qux  #f)
  #t)

(define-macro (in? what equ? . choices)
  (let ((insym 'in))
    `(let ((,insym ,what))
       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
                  choices)))))

(define-syntax vif
  (macro-rules (then else)
    ((_ test (then . xprs))
     `(if ,test
        (begin ,@xprs)))
    ((_ test (else . xprs))
     `(if ,(not test)
        (begin ,@xprs)))
    ((_ test (then . xprs) (else . yprs))
     `(if ,test
        (begin  ,@xprs)
        (begin  ,@yprs)))))

(define (oux)
  (vif #t (then 'true)))

(define (pux)
  (vif #f (else 'false)))

(define-syntax 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))
     `(if #f #f))
    ((_ (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)))
    ))

(define-macro (my-letrec pairs . body)
  (where (pairs (list-of? pair?)))
  (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))))

(define-syntax add
  (macro-rules () ((_ x y)
                   (where (x string?) (y string?))
                   `(string-append ,x ,y))
    (( _ x y)
     (where (x integer?) (y integer?))
     `(+ ,x ,y))))

(define-syntax alambda
  (macro-rules self ()
    ((_ args xpr . xprs)
     `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
        ,self))))

(define-syntax 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 ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))

(define counter ; used for side-effects
  (let ((state 0))
    (lambda ()
      (set! state (+ state 1))
      state)))

(define-macro (square x) ; wrong without once-only
  (once-only (x)
    `(* ,x ,x)))

(define-syntax add2
  (let ((id (lambda (n) n)))
    (macro-rules ()
      ((_ x)
       `(+ ,(id x) 2))
      ((_ x y)
       `(+ ,(id x) ,(id y) 2))
      )))

(define-macro (for (var start end) . body)
  (once-only (start end)
    `(do ((,var ,start (add1 ,var)))
       ((= ,var ,end))
       ,@body)))

(define-test (procedural-macros?)
  (equal? (let ((x 'x) (y 'y))
            (swap! x y)
            (list x y))
          '(y x))

  (eq? (nif 2 'positive 'zero 'negative) 'positive)

  (= ((freeze 5)) 5)

  (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
          '(y x))

  "LITERALS"
  (= (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)

  (= (bar #() 5) 5)

  (qux #f)

  "IN?"
  (in? 2 = 1 2 3)
  (not (in? 5 = 1 2 3))

  "VERBOSE IFS"
  (eq? (oux) 'true)
  (eq? (pux) 'false)

  "LOW-LEVEL COND"
  (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"
  (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))

  "GENERIC ADD"
  (= (add 1 2) 3)
  (string=? (add "x" "y") "xy")

  "ANAPHORIC MACROS"
  (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
          '(1 2 6 24 120))

  (= (mist 5) 120)

  "ONCE-ONLY"
  (= (square (counter)) 1)
  (= (square (counter)) 4)
  (= (square (counter)) 9)
  (let ((lst '()))
    (for (x 0 (counter)) (set! lst (cons x lst)))
    (equal? lst '(3 2 1 0)))

  "LOCAL VARIABLES AVAILABLE IN EACH RULE"
  (= (add2 5) 7)
  (= (add2 5 7) 14)


  "LET AND LETREC"
  (= (macro-letrec (
       ((sec lst) `(car (res ,lst)))
       ((res lst) `(cdr ,lst))
       )
       (sec '(1 2 3)))
     2)
  (= (macro-let (
       ((fir lst) (where (lst list?)) `(car ,lst))
       ((res lst) (where (lst list?)) `(cdr ,lst))
       )
       (fir (res '(1 2 3))))
     2)
  (equal?
    (macro-letrec (((swap1 x y)
                    `(swap2 ,x ,y))
                   ((swap2 x y)
                    (where (x symbol?) (y symbol?))
                    `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
      (let ((x 'x) (y 'y))
        (swap1 x y)
        (swap2 x y)
        (list x y)))
    '(x y))
  (equal?
    (macro-let (((swap1 x y)
                 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
                ((swap2 x y)
                 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
      (let ((x 'x) (y 'y))
        (swap1 x y)
        (swap2 x y)
        (list x y)))
    '(x y))
  )

(compound-test (procedural-macros)
  (basic-macros?)
  (procedural-macros?)
) ; compound test