Skip to content

Instantly share code, notes, and snippets.

@leque
Last active January 20, 2017 00:57
Show Gist options
  • Save leque/ed9e81c434cd20eb68124d71419fcfba to your computer and use it in GitHub Desktop.
Save leque/ed9e81c434cd20eb68124d71419fcfba to your computer and use it in GitHub Desktop.
syntax-rulesズンドコキヨシ、またはマクロ展開時ズンドコキヨシ
#!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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment