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

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

(print "\nWITH-RENAMED-SYMBOLS\n")
(pe '(with-renamed-symbols (gensym %a %b %c) 'body))

(print "\nONCE-ONLY\n")
(pe '(once-only (x)
      `(* ,x ,x)))

(print "\nMY-COND\n")
(pe '
  (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)
    ((_ (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)))
    ))

(print "\nVIF\n")
(pe '
  (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)))))

(newline)

(define-macro (square x)
  (with-explicit-renaming (compare? %*)
    (once-only (x)
      `(,%* ,x ,x))))

(define-macro (wrong-square x)
  (with-explicit-renaming (compare? %*)
    `(,%* ,x ,x)))

(define-test (macro-helpers?)
  (equal? (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
          '(a b c))
  (even? (wrong-square (counter)))
  (integer? (sqrt (square (counter))))
  )

;(macro-helpers?)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
    ((_ (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-syntax vif
  (macro-rules (then else) ;(#: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-syntax aif
  (macro-rules it ()
    ((_ test consequent)
     `(let ((,it ,test))
        (if ,it ,consequent)))
    ((_ test consequent alternative)
     `(let ((,it ,test))
        (if ,it ,consequent ,alternative)))))

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

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

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

(define x 5)

(define-test (macro-rules?)
  (= x 5)
  (= (aif (<< x odd?) it) 5)
  (eq? (vif (odd? x) (then 'odd) (else 'even)) 'odd)
  (= ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
     120)
  "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)
  "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)))
  (= (add 1 2) 3)
  (string=? (add "a" "b") "ab")
  )

;(macro-rules?)

(define-macro (my-letrec pairs xpr . xprs)
  ;(with-implicit-renaming (c?)
    (>> 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)
           ,xpr ,@xprs))));)

(define-macro (eswap! x y)
  (with-explicit-renaming
    (compare? %let %tmp %set!)
     `(,%let ((,%tmp ,x))
        (,%set! ,x ,y)
        (,%set! ,y ,%tmp))))

(define-macro (iswap! x y)
  (with-implicit-renaming (compare?)
    `(let ((tmp ,x))
       (set! ,x ,y)
       (set! ,y tmp)))) 

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

(define-macro (vvif test (then . xprs) (else . yprs))
  (with-explicit-renaming (compare? %then %else %if %begin %error)
    (if (and (compare? then %then) (compare? %else else))
      `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))
      `(,%error 'vif "wrong keys" ',then ',else))))

(define-macro (nif xpr pos zer neg)
  (with-explicit-renaming
    (c? %result %positive? %negative? %let %cond %else)
    `(,%let ((,%result ,xpr))
            (,%cond
              ((,%positive? ,%result) ,pos)
              ((,%negative? ,%result) ,neg)
              (,%else ,zer)))))

(define-macro (aalambda args xpr . xprs)
  (with-implicit-renaming (compare? %self)
    `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
       ,%self)))

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

(define-macro (for (var start end) xpr . xprs)
  ;(with-implicit-renaming (c?)
    (once-only (start end)
      `(do ((,var ,start (add1 ,var)))
         ((= ,var ,end))
         ,xpr ,@xprs)));)

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

(define-test (define-macro?)
  (equal? (let ((x 'x) (y 'y))
            (eswap! x y)
            (list x y))
          '(y x))
  (equal? (let ((x 'x) (y 'y))
            (iswap! x y)
            (list x y))
          '(y x))
  (equal? (let ((x 'x) (y 'y))
            (swap! x y)
            (list x y))
          '(y x))
  (= x 5)
  (= ((aalambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5) 120)
  (eq? (vvif (odd? x) (then 'odd) (else 'even)) 'odd)
  (eq? (nif 2 'positive 'zero 'negative) 'positive)
  (in 2 = 1 2 3)
  (not (in 5 = 1 2 3))
  (= ((freeze 5)) 5)
  (let ((lst '()))
    (for (x 0 (counter)) (set! lst (cons x lst)))
    (equal? lst '(3 2 1 0)))
  "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))
  )

;(define-macro?)

(define-test (macrolet?)
  (= (macro-let (
      ((first lst)
       `(begin
          (>> ,lst list?)
          (car ,lst)))
      ((rest lst)
       `(begin
          (>> ,lst list?)
          (cdr ,lst)))
      )
      (first (rest '(1 2 3))))
     2)
  (= (macro-letrec (
      ((second lst) `(car (rest ,lst)))
      ((rest lst) `(cdr ,lst))
      )
      (second '(1 2 3)))
     2)
  (equal?
    (macro-letrec (
      ((swap1 x y)
       `(swap2 ,x ,y))
      ((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))
  (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))
  )

;(macrolet?)
;
(compound-test (PROCEDURAL-MACROS)
  (macro-helpers?)
  (macro-rules?)
  (define-macro?)
  (macrolet?)
  )
;