syntax-rulesズンドコキヨシ、またはマクロ展開時ズンドコキヨシ

ck-zundoko.scm

#!r6rs
(import (rnrs))

;; R7RS 処理系で実行する場合は、上の行をコメントアウトし、
;; 下の行のコメントを外す
;; (import (scheme base) (scheme write))

;; R5RS 処理系で実行する場合は、ここから上をすべてコメントアウトする

;; From "Applicative syntax-rules: macros that compose better",
;; http://okmij.org/ftp/Scheme/macros.html#ck-macros
(define-syntax ck
  (syntax-rules (quote)
    ;; yield the value on empty stack
    ((ck () 'v) v)
    ;; re-focus on the other argument, ea
    ((ck (((op ...) ea ...) . s) 'v)
     (ck s "arg" (op ... 'v) ea ...))
    ;; all arguments are evaluated,
    ;; do the redex
    ((ck s "arg" (op va ...))
     (op s va ...))
    ;; optimization when the first ea
    ;; was already a value
    ((ck s "arg" (op ...) 'v ea1 ...)
     (ck s "arg" (op ... 'v) ea1 ...))
    ;; focus on ea, to evaluate it
    ((ck s "arg" (op ...) ea ea1 ...)
     (ck (((op ...) ea1 ...) . s) ea))
    ;; Focus: handle an application;
    ;; check if args are values
    ((ck s (op ea ...))
     (ck s "arg" (op) ea ...))
    ))

;;; "syntax-rulesズンドコキヨシ、またはマクロ展開時ズンドコキヨシ"
;;; http://qiita.com/dico_leque/items/e2c7a88df2e9dfe9a446

(define-syntax ck-add
  (syntax-rules (quote)
    ((_ s '() 'n)
     (ck s 'n))
    ((_ s '(_ . m) 'n)
     (ck s (ck-add 'm '(1 . n))))))

(define-syntax ck-sub
  (syntax-rules (quote)
    ((_ s '() 'n)
     (ck s '()))
    ((_ s 'm '())
     (ck s 'm))
    ((_ s '(s1 . m) '(s2 . n))
     (ck s (ck-sub 'm 'n)))))

(define-syntax ck-mul
  (syntax-rules (quote)
    ((_ s '() '_)
     (ck s '()))
    ((_ s '(_ . m) 'n)
     (ck s (ck-add 'n (ck-mul 'm 'n))))))

(define-syntax syn-nat<
  (syntax-rules ()
    ((_ _ () then else)
     else)
    ((_ () _ then else)
     then)
    ((_ (s1 . m) (s2 . n) then else)
     (syn-nat< m n then else))))

(define-syntax ck-mod
  (syntax-rules (quote)
    ((_ s 'm '())
     (ck s 'm))
    ((_ s 'm 'n)
     (syn-nat< m n
               (ck s 'm)
               (ck s (ck-mod (ck-sub 'm 'n) 'n))))))

(define-syntax ck-lcg-next
  (syntax-rules (quote)
    ;; X_{n+1} = (A X_n + C) \pmod{M}
    ((_ s 'a 'xn 'c 'm)
     (ck s (ck-mod (ck-add (ck-mul 'a 'xn) 'c) 'm)))))

(define-syntax ck-cons
  (syntax-rules (quote)
    ((_ s 'h 't)
     (ck s '(h . t)))))

(define-syntax ck-revappend
  (syntax-rules (quote)
    ((_ s '() 'ys)
     (ck s 'ys))
    ((_ s '(x . xs) 'ys)
     (ck s (ck-revappend 'xs (ck-cons 'x 'ys))))))

(define-syntax ck-reverse
  (syntax-rules (quote)
    ((_ s 'xs)
     (ck s (ck-revappend 'xs '())))))

(define-syntax ck-zundoko
  (syntax-rules (quote)
    ((_ s 'xn '("ドコ" "ズン" "ズン" "ズン" "ズン" . rest))
     (ck s
         (ck-reverse
          (ck-cons '"キ・ヨ・シ！"
                   '("ドコ" "ズン" "ズン" "ズン" "ズン" . rest)))))
    ((_ s 'xn 'zs)
     (ck s (ck-zundoko-next 'xn 'zs)))))

(define-syntax ck-zundoko-next
  (syntax-rules (quote)
    ((_ s 'xn 'ys)
     (ck s (ck-zundoko-next~
            ;; X_{n+1} = (5 X_n + 3) \pmod{8}
            (ck-lcg-next '(1 2 3 4 5)
                         'xn
                         '(1 2 3)
                         '(1 2 3 4 5 6 7 8))
            'ys)))))

(define-syntax ck-zundoko-next~
  (syntax-rules (quote)
    ((_ s 'xn+1 'ys)
     (syn-nat< xn+1 (1 2 3 4)
               ;; 0, 1, 2, 3 のとき
               (ck s (ck-zundoko 'xn+1 '("ドコ" . ys)))
               ;; 4, 5, 6, 7 のとき
               (ck s (ck-zundoko 'xn+1 '("ズン" . ys)))))))

(define-syntax ck-quote
  (syntax-rules (quote)
    ((_ s 'x)
     (ck s ''x))))

(for-each (lambda (x)
            (display " ")
            (display x))
          (ck () (ck-quote (ck-zundoko '(1) '()))))
(newline)