(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)
                   )

;;; COND AND CASE AS ER- OR IR-MACRO
(define-er-macro er-cond
  ((_ (else xpr . xprs))
   (where (key? else))
   %
   `(,%begin ,xpr ,@xprs))
  ((_ (test => xpr))
   (where (key? =>))
   %
   `(,%let ((,%tmp ,test))
      (,%if ,%tmp (,xpr ,%tmp))))
  ((_ (test => xpr) . clauses)
   (where (key? =>))
   %
   `(,%let ((,%tmp ,test))
      (,%if ,%tmp
        (,xpr ,%tmp)
        (,%er-cond ,@clauses))))
  ((_ (test))
   %
   ;`(if #f #f))
   test)
  ((_ (test) . clauses)
   %
   `(,%let ((,%tmp ,test))
      (,%if ,%tmp
        ,%tmp
        (,%er-cond ,@clauses))))
  ((_ (test xpr . xprs))
   %
   `(,%if ,test (,%begin ,xpr ,@xprs)))
  ((_ (test xpr . xprs) . clauses)
   %
   `(,%if ,test
      (,%begin ,xpr ,@xprs)
      (,%er-cond ,@clauses)))
  )

(define-ir-macro ir-case* ; helper
  ((_ key (else result . results))
   (where (key? else))
   %
   `(begin ,result ,@results))
  ((_ key (keys result . results))
   %
   `(if (memv ,key ',keys)
      (begin ,result ,@results)))
  ((_ key (keys result . results) clause . clauses)
   %
   `(if (memv ,key ',keys)
      (begin ,result ,@results)
      (ir-case* ,key ,clause ,@clauses)))
  )

(define-ir-macro (ir-case key clause . clauses)
  %
  ;`(let ((tmp ,key)) ; ok
  ;   (ir-case* tmp ,clause ,@clauses)))
  (let ((tmp key)) ; ok
    `(ir-case* ,tmp ,clause ,@clauses)))


;;; ALAMBDA AS ER- AND IR-MACRO
(define-ir-macro (ir-alambda args xpr . xprs)
  %
  `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
     ,%self))

(define-er-macro (er-alambda args xpr . xprs)
  %
  `(,%letrec ((self (,%lambda ,args ,xpr ,@xprs)))
     self))


;;; NUMERIC AND VERBOSE IF
(define-er-macro (er-nif xpr pos zer neg)
  %
  `(,%let ((,%result ,xpr))
     (,%cond
       ((,%positive? ,%result) ,pos)
       ((,%negative? ,%result) ,neg)
       (,%else ,zer))))

(define-er-macro er-vif
  ((_ test (then . xprs) (else . yprs))
   (where (key? then) (key? else))
   %
   `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs))))

(define ir-case-test #f)
(define ir-!-test #f)
(define er-nif-test #f)
(define er-vif-test #f)

(define-checks (Er-ir-checks verbose?)
  (er-cond ((> 3 2)))
  #t
  (er-cond ((> 3 2) 'greater))  ;;; wrong
  'greater
  (er-cond ((< 3 2) 'greater)
           (else 'unknown))
  'unknown
  (er-cond ((> 3 2) 'greater)
           (else 'unknown))
  'greater
  (er-cond ((> 3 2) 'greater)
           ((< 3 2) 'less))
  'greater
  (er-cond
    ((> 3 3) 'greater)
    ((< 3 3) 'less)
    (else 'equal))
  'equal
  (er-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
           (else #f))
  2
  (er-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
           (else #f))
  #f
  (set! ir-case-test
    (lambda (n)
      (ir-case n
        ((1 3 5 7 9) 'odd)
        ((0 2 4 6 8) 'even)
        (else 'too-large)
        )))
  (if #f #f)
  (ir-case-test 5)
  'odd
  (ir-case-test 2)
  'even
  (set! ir-!-test
    (ir-alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
  (if #f #f)
  (ir-!-test 5)
  120
  (set! er-nif-test
    (lambda (n)
      (er-nif n 'pos 'zer 'neg)))
  (if #f #f)
  (er-nif-test 0)
  'zer
  (er-nif-test 5)
  'pos
  (set! er-vif-test
    (lambda (n)
      (er-vif (odd? n) (then 'odd) (else 'even))))
  (if #f #f)
  (er-vif-test 5)
  'odd
  (er-vif-test 0)
  'even
  )
;(Er-ir-checks)

(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)))

(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-checks (Helpers verbose?)
  (with-renamed-symbols (identity %a %b %c) (list %a %b %c))
  '(a b c)
  (even? (wrong-square (counter)))
  #t
  (integer? (sqrt (square (counter))))
  #t
  )
;(Helpers)

(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-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)
    ((_ 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) (where (string? a))
             `(list ,a ,b))
    ((_ a b) (where (odd? a))
             `(list ,a ,b))
    ((_ a b) a)))

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

(define-checks (Rules verbose? x 5)
  x
  5
  (aif (<< x odd?) it)
  5
  (vif (odd? x) (then 'odd) (else 'even))
  'odd
  ((alambda (n) (if (= n 1) 1 (* n (self (- n 1))))) 5)
  120
  (foo "foo" 1)
  1
  (foo "bar" 2)
  '("bar" 2)
  (foo #f 'blabla)
  '(false)
  (foo 1 2)
  '(1 2)
  (foo 2 3)
  2
  (my-cond ((> 3 2)))
  #t
  (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
  'greater
  (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
  (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
           (else #f))
  #f
  (add 1 2)
  3
  (add "a" "b")
  "ab"
  )
;(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)
  (let ((insym 'in))
    `(let ((,insym ,what))
       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
                  choices)))))

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

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

(define-checks (Defines verbose?  x 5)
  (let ((x 'x) (y 'y))
    (eswap! x y)
    (list x y))
  '(y x)
  (let ((x 'x) (y 'y))
    (iswap! x y)
    (list x y))
  '(y x)
  (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
  (vvif (odd? x) (then 'odd) (else 'even))
  'odd
  (nif 2 'positive 'zero 'negative)
  'positive
  (in 2 = 1 2 3)
  #t
  (in 5 = 1 2 3)
  #f
  ((freeze 5))
  5
  (let ((lst '()))
    (for (x 0 4) (set! lst (cons x lst)))
    lst)
  '(3 2 1 0)
  (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)
  )
;(Defines)

(define-checks (Lets verbose?)
  (macro-let (
   ((first lst)
    `(car (<< ,lst list?)))
   ((rest lst)
    `(cdr (<< ,lst list?)))
   )
   (first (rest '(1 2 3))))
  2
  (macro-letrec (
   ((second lst) `(car (rest ,lst)))
   ((rest lst) `(cdr ,lst))
   )
   (second '(1 2 3)))
  2
  (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)
  (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)
  )
;(Lets)
;
(check-all MACROS (Er-ir-checks) (Helpers) (Rules) (Defines) (Lets))