Paul Graham の著書でマクロのことが満載の本。ただし Lisp で書いてある。 文中気になったコードをSchemeで書いてみるコーナー。 （セクションタイトルその他の邦訳は 野田さんの邦訳 をそのまま引用させてもらいます）
マクロはどのように、そしてなぜ違うのかを知ることは、マクロを正しく使うための鍵だ。 関数は結果を生むが、マクロは式を生む。----そしてこの式が評価されると結果を生む。 (「7 マクロ」から)
マクロの引数は式であって値ではないことを忘れてはならない。 (「10.1 評価の回数」から)
(define (complement pred) (lambda args (not (apply pred args))))
(define (memoize fn)
(let ((cache (make-hash-table 'equal?)))
(lambda args
(if (hash-table-exists? cache args)
(hash-table-get cache args)
(let ((val (apply fn args)))
(hash-table-put! cache args val)
val)))))
(define (compose . fns)
(if (null? fns)
identity
(let ((fn1 (car (reverse fns)))
(fns (reverse (cdr (reverse fns)))))
(lambda args ((apply compose fns) (apply fn1 args))))))
(define (fif pred then . alt)
(lambda args
(if (apply pred args)
(apply then args)
(if (null? alt)
#f
(apply (car alt) args)))))
(define (fint fn . fns)
(if (null? fns)
fn
(lambda args
(and (apply fn args)
(apply (apply fint fns) args)))))
(define (fun fn . fns)
(if (null? fns)
fn
(lambda args
(or (apply fn args)
(apply (apply fun fns) args)))))
funcall が欲しいね。
(define (funcall fn . args) (apply fn args))
fun->GaucheRefj:any-pred ですね。
この Cdr down な再帰の抽象構造の抽出は結構動作が難解に思う。
(define (lrec rec . base)
(letrec ((self (lambda (lst)
(if (null? lst)
(let ((base (get-optional base '())))
(if (procedure? base)
(base)
base))
(rec (car lst)
(lambda ()
(self (cdr lst))))))))
self))
使ってみればなんとなく分からなくもない。
gosh> ((lrec (lambda (x f) (+ 1 (f))) 0) (iota 10 1))
10
gosh> ((lrec (lambda (x f) (* x (f))) 1) (iota 10 1))
3628800
gosh> ((lrec (lambda (x f) (and (odd? x) (f))) #t) '(1 3 5 7 9))
#t
gosh> ((lrec (lambda (x f) (string-append x (f))) "") '("a" "b" "c"))
"abc"
gosh> (define lst '(1 2 3))
lst
gosh> (eq? lst lst)
#t
gosh> (eq? lst ((lrec (lambda (x f) (cons x (f)))) lst))
#f
(define (ttrav rec . base)
(letrec ((self (lambda (tree)
(if (atom? tree)
(let ((base (get-optional base identity)))
(if (procedure? base)
(base tree)
base))
(rec (self (car tree))
(self (cdr tree)))))))
self))
さらに一般的なツリー用再帰関数生成関数だそうだ。
(define (trec rec . base)
(letrec ((self (lambda (tree)
(if (atom? tree)
(let ((base (get-optional base identity)))
(if (procedure? base)
(base tree)
base))
(rec tree
(lambda ()
(self (car tree)))
(lambda ()
(self (cdr tree))))))))
self))
[2]> (funcall (ttrav #'nconc #'list) '((1 2) 3)) (1 2 3)このページで定義された ttrav の実行結果
gosh> ((ttrav append! list) '((1 2) 3)) (1 2 () 3 ())
(define (ttrav rec . base)
(let ((base (get-optional base identity)))
(letrec ((self (lambda (tree)
(if (atom? tree)
(if (procedure? base)
(base tree)
base)
(rec (self (car tree))
(if (not-null? (cdr tree))
(self (cdr tree)) '()))))))
self)))
(define (trec rec . base)
(let ((base (get-optional base identity)))
(letrec ((self (lambda (tree)
(if (atom? tree)
(if (procedure? base)
(base tree)
base)
(rec tree
(lambda ()
(self (car tree)))
(lambda ()
(if (not-null? (cdr tree))
(self (cdr tree)) '())))))))
self)))
count-leaves にあたる (ttrav #'(lambda (l r) (+ l (or r l))) 1) の使用時に、
やはりエラーがでるからだ。なぜなら or も又同様に '() を偽と見なすから。
うーむ。やるとしたら atom? を (not (list? x)) にして
微妙にロジックを Scheme ちっくに合わせてやるのかなぁ。 confuse して来た・・・。
test をページの尻に置いてみるけど現時点では 1-13 が fail します。cut-sea:2004/11/26 19:01:48 PST
(define (trec rec . base)
(let ((base (get-optional base identity)))
(letrec ((self (lambda (tree)
(if (atom? tree)
(if (procedure? base)
(base tree)
base)
(rec tree
(lambda ()
(self (car tree)))
(lambda ()
(self (cdr tree))))))))
self)))
さぁ、いよいよだ。ポキポキ。
(define-macro (nil! var) `(set! ,var #f))
どうでもいいけど、ここで言う nil を #f とすべきか '() とすべきか。
それより、ここで呼ばれている set! は srfi-17 の set! であることの方が。
(Gaucheではデフォルトで一般化参照だ)
(define-macro (when test . body) `(if ,test (begin ,@body)))
(define-macro (while test . body)
`(do ()
((not ,test))
,@body))
元ネタの Lisp コードでは
(defmacro our-dolist ((var list &optional result) &body body) ...
とあるが、こういう引数の持たせ方がちょっと・・・ねぇ。 Gaucheにはダイレクトに dolist もあるけど、中を作ってみるのが趣旨なんで、 気分を変えて util.match を使ってみた。
(define-macro (dolist var-lst-res . body)
(match var-lst-res
((var lst . res)
`(begin
(map (lambda (,var) ,@body)
,lst)
(let ((,var '()))
,@res)))))
ちなみに Gauche の common-macros 中の dolist は define-syntax で定義。
(define-syntax dolist
(syntax-rules ()
((_ (var lis res) . body)
(begin (for-each (lambda (var) . body) lis)
(let ((var '())) res)) ;bound var for CL compatibility
)
((_ (var lis) . body)
(begin (for-each (lambda (var) . body) lis) '()))
((_ . other)
(syntax-error "malformed dolist" (dolist . other)))))
引数リストがこういうケースの場合には、hygienic macro 使った方がスマートだ。
(define-macro (when-bind var-expr . body)
(match var-expr
((var expr)
`(let ((,var ,expr))
(when ,var ,@body)))))
defmacro の概形は形もそもそも違うのでちょっと今は手が出ない。 ただ、 概形に出て来る block は書いてみよう。こことか参考に攻めてみる。
(define-macro (block tag . body) `(call/cc (lambda (,tag) ,@body)))
rest 引数の扱い方二種類。
(define-macro (sum1 . args) `(apply + (list ,@args))) (define-macro (sum . args) `(+ ,@args))
(define-macro (avg . args) `(/ (+ ,@args) ,(length args)))
これは
(%macroexpand-1 (avg 1 2 3 4 5)) => (/ (+ 1 2 3 4 5) 5)
ってな具合にマクロ展開時に length が評価されるとこがポイントだそうだ。
最初の with 系マクロ。 すでに Scheme プレフィックスじゃなくなってるけど。
(define-macro (with-redraw var-objs . body)
(match var-objs
((var objs)
(let ((gob (gensym))
(x0 (gensym)) (y0 (gensym))
(x1 (gensym)) (y1 (gensym)))
`(let ((,gob ,objs))
(receive (,x0 ,y0 ,x1 ,y1) (bounds ,gob)
(dolist (,var ,gob) ,@body)
(receive (xa ya xb yb) (bounds ,gob)
(redraw (min ,x0 xa) (min ,y0 ya)
(max ,x1 xb) (max ,y1 yb)))))))))
実行例はこんな感じ。(drawのライブラリもページの下に付ける)
gosh> (%macroexpand-1 (with-redraw (o (list obj1 obj2 obj3)) (draw o))) (let ((G249 (list obj1 obj2 obj3))) (receive (G250 G251 G252 G253) (bounds G249) (dolist (o G249) (draw o)) (receive (xa ya xb yb) (bounds G249) (redraw (min G250 xa) (min G251 ya) (max G252 xb) (max G253 yb))))) gosh> (with-redraw (o (list obj1 obj2 obj3)) (draw o)) draw: LINE(3,13)->(-7,8) draw: LINE(16,-6)->(9,1) draw: LINE(-12,8)->(11,-2) We redraw for Square from (-12,-6) to (16,13) #<undef>
なんとなく途中の動きが分かるようにマメに debug draw してみる。
gosh> obj1
#ln[#pt[3,13]-#pt[-7,8]]
gosh> obj2
#ln[#pt[16,-6]-#pt[9,1]]
gosh> obj3
#ln[#pt[-12,8]-#pt[11,-2]]
gosh> (with-redraw (o (list obj1 obj2 obj3))
(draw o)
(horizontal-mirror! o)
(draw o)
(vertical-mirror! o)
(draw o)
(move-by! o 10 -10)
(draw o))
draw: LINE(3,13)->(-7,8)
draw: LINE(3,8)->(-7,13)
draw: LINE(-7,8)->(3,13)
draw: LINE(3,-2)->(13,3)
draw: LINE(16,-6)->(9,1)
draw: LINE(16,1)->(9,-6)
draw: LINE(9,1)->(16,-6)
draw: LINE(19,-9)->(26,-16)
draw: LINE(-12,8)->(11,-2)
draw: LINE(-12,-2)->(11,8)
draw: LINE(11,-2)->(-12,8)
draw: LINE(21,-12)->(-2,-2)
We redraw for Square from (-12,-16) to (26,13)
#<undef>
gosh> obj1
#ln[#pt[3,-2]-#pt[13,3]]
gosh> obj2
#ln[#pt[19,-9]-#pt[26,-16]]
gosh> obj3
#ln[#pt[21,-12]-#pt[-2,-2]]
gosh>
gosh> (with-redraw (o (list obj1 obj2 obj3))
(draw o)
(move-by! o 10 -10)
(draw o)
(move-by! o -10 10)
(draw o))
draw: LINE(3,13)->(-7,8)
draw: LINE(13,3)->(3,-2)
draw: LINE(3,13)->(-7,8)
draw: LINE(16,-6)->(9,1)
draw: LINE(26,-16)->(19,-9)
draw: LINE(16,-6)->(9,1)
draw: LINE(-12,8)->(11,-2)
draw: LINE(-2,-2)->(21,-12)
draw: LINE(-12,8)->(11,-2)
We redraw for Square from (-12,-6) to (16,13)
#<undef>
(with-draw-to-canvas (make-canvas w h) (lambda (p) ...))みたいな形式が自然で、全部 (draw port ...) 形式に書きかえるのがいいんだろうけど、 これだとマクロじゃなくて単なる closure ですんじゃうから、 On Lisp 的にはつまんなくなるんだろうなぁ。cut-sea:2004/12/06 18:06:43 PST
まず間違った for
(define-macro (bad-for var-start-stop . body)
(match var-start-stop
((var start stop)
`(do ((,var ,start (+ ,var 1))
(limit ,stop))
((> ,var limit))
,@body))))
これ見てすぐ浮かぶ正しい for だけど、 実は On Lisp 中では、この後いろんな方法での解決策が説明されている
(define-macro (for var-start-stop . body)
(match var-start-stop
((var start stop)
(let ((limit (gensym)))
`(do ((,var ,start (+ ,var 1))
(,limit ,stop))
((> ,var ,limit))
,@body)))))
(define-macro (echo . args) `'(,@args amem))
(define-macro (nth n lst)
`(letrec ((nth-fn (lambda (n lst)
(if (= n 0)
(car lst)
(nth-fn (- n 1) (cdr lst))))))
(nth-fn ,n ,lst)))
(define-macro (orb . args)
(if (null? args)
#f
(let ((sym (gensym)))
`(let ((,sym ,(car args)))
(if ,sym
,sym
(orb ,@(cdr args)))))))
(define-macro (our-let binds . body)
`((lambda ,(map (lambda (x)
(if (pair? x) (car x) x))
binds)
,@body)
,@(map (lambda (x)
(if (pair? x) (cadr x) #f))
binds)))
(define-macro (when-bind* binds . body)
(if (null? binds)
`(begin ,@body)
`(let (,(car binds))
(if ,(caar binds)
(when-bind* ,(cdr binds) ,@body)))))
(define-macro (with-gensyms syms . body)
`(let ,(map (lambda (s)
`(,s (gensym)))
syms)
,@body))
(define-macro (condlet clauses . body)
(let ((bodfn (gensym))
(vars (map (lambda (v) (cons v (gensym)))
(delete-duplicates
(map car (append-map cdr clauses))))))
`(letrec ((,bodfn (lambda ,(map car vars)
,@body)))
(cond ,@(map (lambda (cl)
(condlet-clause vars cl bodfn))
clauses)))))
(define (condlet-clause vars cl bodfn)
`(,(car cl) (let ,(map (lambda (v) (list v #f))
(map cdr vars))
(let ,(condlet-binds vars cl)
(,bodfn ,@(map cdr vars))))))
(define (condlet-binds vars cl)
(map (lambda (bindform)
(if (pair? bindform)
(cons (cdr (assoc (car bindform) vars))
(cdr bindform))))
(cdr cl)))
マクロが返すのは式だ。 上記のcondlet-clause,condlet-bindsや、ここで出現する>casex などの マクロに埋め込まれた関数は値を返すが、 その値は scheme の式でもある list であり、元のマクロの返す式の一部を構成する。
(define-macro (in obj . choices)
(let ((insym (gensym)))
`(let ((,insym ,obj))
(or ,@(map (lambda (c) `(equal? ,insym ,c))
choices)))))
(define-macro (inq obj . args)
`(in ,obj ,@(map (lambda (a) `',a)
args)))
(define-macro (in-if fn . choices)
(let ((fnsym (gensym)))
`(let ((,fnsym ,fn))
(or ,@(map (lambda (c) `(,fnsym ,c))
choices)))))
(define-macro (>case expr . clauses)
(let ((g (gensym)))
`(let ((,g ,expr))
(cond ,@(map (lambda (cl) (>casex g cl))
clauses)))))
(define (>casex g cl)
(let ((key (car cl)) (rest (cdr cl)))
(cond ((pair? key) `((in ,g ,@key) ,@rest))
((inq key #t otherwise) `(#t ,@rest))
(else (error "bad >case clause")))))
map0-n nthcdr はモジュール内部でのみ利用する。 do-tuples/o の map0-n 中 nthcdr の前に "," が付いているが、 これは nthcdr がモジュール外に公開されていれば不要。 逆に外部に別仕様の nthcdr があると微妙な bug になるだろう。 これもまたマクロが式 (nthcdr ...) を返すことを意識する必要があるところだ。 ここに "," を付けることでクロージャの実体に置き換えられる。
(define (map0-n fn len)
(map fn (iota (+ len 1))))
(define (map1-n fn len)
(map fn (iota len 1)))
(define (nthcdr n lst)
(if (null? lst)
'()
(if (<= n 0)
lst
(nthcdr (- n 1) (cdr lst)))))
(define-macro (do-tuples/o parms source . body)
(if (not-null? parms)
(let ((src (gensym)))
`(let ((,src ,source))
(for-each (lambda ,parms ,@body)
,@(map0-n (lambda (n)
`(,nthcdr ,n ,src))
(- (length parms) 1)))))))
(define-macro (do-tuples/c parms source . body)
(if (not-null? parms)
(with-gensyms (src rest bodfn)
(let ((len (length parms)))
`(let ((,src ,source))
(when (,not-null? (,nthcdr ,(- len 1) ,src))
(letrec ((,bodfn (lambda ,parms ,@body)))
(do ((,rest ,src (cdr ,rest)))
((null? (,nthcdr ,(- len 1) ,rest))
,@(map (lambda (args)
`(,bodfn ,@args))
(dt-args len rest src))
#f)
(,bodfn ,@(map1-n (lambda (n)
`(nth ,(- n 1)
,rest))
len))))))))))
(define (dt-args len rest src)
(map0-n (lambda (m)
(map1-n (lambda (n)
(let ((x (+ m n)))
(if (>= x len)
`(nth ,(- x len) ,src)
`(nth ,(- x 1) ,rest))))
len))
(- len 2)))
set!-values のところに注意。receive ではダメ。副作用が必要だ。
(define-macro (mvdo* parm-cl test-cl . body)
(mvdo-gen parm-cl parm-cl test-cl body))
(define (mvdo-gen binds rebinds test body)
(if (null? binds)
(let ((label (gensym))
(return (gensym)))
`(block ,return
(let ,label ()
(if ,(car test)
(,return (begin ,@(cdr test))))
,@body
,@(mvdo-rebind-gen rebinds)
(,label))))
(let ((rec (mvdo-gen (cdr binds) rebinds test body)))
(let ((var/s (caar binds)) (expr (cadar binds)))
(if (not (pair? var/s))
`(let ((,var/s ,expr)) ,rec)
`(receive ,var/s ,expr ,rec))))))
(define (mvdo-rebind-gen rebinds)
(cond ((null? rebinds) '())
((< (length (car rebinds)) 3)
(mvdo-rebind-gen (cdr rebinds)))
(else (cons (list (if (not (pair? (caar rebinds)))
'set!
'set!-values)
(caar rebinds)
(list-ref (car rebinds) 2))
(mvdo-rebind-gen (cdr rebinds))))))
mvdo のための準備だそうだが、 mvpsetq 以前に Lisp の setq を実装するのが どうやったらいいんだろう。 気になるところが以下の二点だ。
(let ((w 0) (x 1) (y 2) (z 3)) (mvpsetq (w x) (values 'a 'b) (y z) (values w x)) (list w x y z))とかは結局 lambda に置き換えられるので w とか x とかってのは、 単なる引数順の目印であって、シンボル自体は意味ないしな。 define されたものじゃないからなんともならんが、手はありや？
(define-macro (setq . args)
(if (null? args)
'()
(let ((pairs (group args 2)))
`(begin
,@(map (lambda (p)
`(guard (e (#t (eval '(define ,@p)
(current-module))))
(set! ,@p)))
pairs)))))
(define-macro (mvpsetq . args)
(let* ((pairs (group args 2))
(syms (map (lambda (p)
(map (lambda _ (gensym))
(mklist (car p))))
pairs)))
(letrec ((rec (lambda (ps ss)
(if (null? ps)
`(setq ;; できれば ,setq として隠蔽したいが...
,@(append-map (lambda (p s)
(shuffle (mklist (car p))
s))
pairs syms))
(let ((body (rec (cdr ps) (cdr ss))))
(let ((var/s (caar ps))
(expr (cadar ps)))
(if (pair? var/s)
`(receive ,(car ss)
,expr
,body)
`(let ((,@(car ss) ,expr))
,body))))))))
(rec pairs syms))))
(mvpsetq x 1 (y z) (values 2 3))
=> (let ((G80 1)) (receive (G81 G82) (values 2 3) (setq x G80 y G81 z G82)))
=> *** ERROR: unbound variable: G80
Stack Trace:
_______________________________________
0 (with-error-handler (lambda (e) (let ((e e)) (%guard-rec e e (#t ( ...
[unknown location]
テストを追加してみて分かったことは、 mvpsetq をトップレベルで直接呼ぶとダメ。
なんでだろう setq の展開では guard 使ってうまく処理したつもりなのに。(+_+;gosh> (let ((x 10)) (define y x)) 10 gosh> (let ((x 10) (y 20)) (set! y x)) 10と同じで、参照出来そうなのに、マクロ展開されるタイミングを勘違いしてるのかなぁ。cut-sea:2004/12/31 13:40:48 PST
(let ((x 10))
(guard (e (#t (eval '(define y x)
(current-module))))
(set! y x)))
これが、(eval '(define y x) (current-module)) だからか。
teranishi さんのおっしゃってたトップレベルで (define x G80) を評価云々の
部分はそういうことですね。
ってことは…。(~_~)!
(define-macro (setq . args)
(if (null? args)
'()
(let ((pairs (group args 2)))
`(begin
,@(map (lambda (p)
`(guard (e (#t (eval `(define ,',(car p) ',,(cadr p))
(current-module))))
(set! ,@p)))
pairs)))))
gosh> (%macroexpand-1 (setq x a y b))
(begin
(guard (e (#t (eval `(define ,'x ',a)
(current-module))))
(set! x a))
(guard (e (#t (eval `(define ,'y ',b)
(current-module))))
(set! y b)))
5.1 番目が値を取り出しているのか。
(eval ...) 式の評価において、eval は subr だから、
その引数が評価されるタイミングでカンマ "," を使って置き換えるわけか。
ちなみに 6 番目では (define x '(a の値)) が評価される段階で、
x はそのまま評価されず、二番目の引数は ' が外れて
最終的に "a の値" がむき出しになる、と。
これをサボるとシンボルを束縛してたときにエラーが出る。
分かるけど自分ではまだ書けそうにない。teranishiさんThanks!!
(define-macro (mvdo binds test-result . body)
(match test-result
((test . result)
(let ((label (gensym))
(return (gensym))
(temps (map (lambda (b)
(if (pair? (car b))
(map (lambda (x)
(gensym))
(car b))
(gensym)))
binds)))
`(let ,(map list
(append-map mklist temps)
(make-list (length (append-map mklist temps)) #f))
(mvpsetq ,@(append-map (lambda (b var)
(list var (cadr b)))
binds
temps))
(block ,return
(let ,(map (lambda (b var) (list b var))
(append-map mklist (map car binds))
(append-map mklist temps))
(let ,label ()
(if ,test
(,return (begin ,@result)))
,@body
(mvpsetq ,@(append-map (lambda (b)
(if (caddr b)
(list (car b)
(caddr b))))
binds))
(,label)))))))))
(define-macro (allf val . args)
(with-gensyms (gval)
`(let ((,gval ,val))
(setq ,@(append-map (lambda (a) (list a gval))
args)))))
いわゆる一般化参照。
gauche.sequence を import。 マクロでは複数回評価される場合には、与えられた式に副作用がある場合を 考慮するためにどうしても面倒な前処理が増えてしまう。
(define-macro (symbol-value sym)
`(eval ,sym (current-module)))
(define (make-gensym n)
(if (= n 0) '() (cons (gensym) (make-gensym (- n 1)))))
(define (get-setf-method place)
(cond ((symbol? place)
(let ((g (gensym)))
(values '() '() (list g) `(set! ,place ,g) place)))
((pair? place)
(let* ((forms (cdr place))
(vars (make-gensym (length forms)))
(var (list (gensym)))
(set `((setter ,(car place)) ,@vars ,@var))
(access (cons (car place) vars)))
(values vars forms var set access)))))
(define-macro (_! op place . args)
(receive (vars forms var set access)
(get-setf-method place)
`(let* (,@(map list vars forms)
(,(car var) (,op ,access ,@args)))
,set)))
(define-macro (pull obj place . args)
(receive (vars forms var set access)
(get-setf-method place)
(let ((g (gensym)))
`(let* ((,g ,obj)
,@(map list vars forms)
(,(car var) (,delete ,g ,access ,@args)))
,set))))
(define-macro (pull-if test place)
(receive (vars forms var set access)
(get-setf-method place)
(let ((g (gensym)))
`(let* ((,g ,test)
,@(map list vars forms)
(,(car var) (,remove ,g ,access)))
,set))))
(define-macro (popn n place)
(receive (vars forms var set access)
(get-setf-method place)
(with-gensyms (gn glst)
`(let* ((,gn ,n)
,@(map list vars forms)
(,glst ,access)
(,(car var) (,nthcdr ,gn ,glst)))
(begin0 (,subseq ,glst ,gn)
,set)))))
gosh> (define my-car car)
my-car
gosh> (define x (list 1 2))
x
gosh> (_! + (my-car x) 1)
*** ERROR: unbound variable: my-car
Stack Trace:
_______________________________________
0 (eval (car place) (current-module))
[unknown location]
1 (get-setf-method place)
At line 448 of "./onlisp.scm"
これを回避するためには、コンパイル時に setter を求めるのではなく、
実行時に求めるようにする必要があります。
(get-setf-methodで、,(setter refer) の代わりに (setter ,(car place)) を使う)
sortf あたりは確かにコンパイル時にいろいろやってる雰囲気がある。
"onlisp sortf 3" の test 見てると、とんでもなく凄いことが記述出来てる気がする。
(define-macro (rotatef . args)
(let* ((meths (map (lambda (p)
(call-with-values
(lambda _ (get-setf-method p)) list))
args))
(temps (apply append (map third meths))))
`(let* ,(map list
(append-map (lambda (m)
(append (first m)
(third m)))
meths)
(append-map (lambda (m)
(append (second m)
(list (fifth m))))
meths))
;; rotate logic...
(mvpsetq ,@(append-map list temps (cdr temps))
,(last temps) ,(car temps))
;; for set! effect.
,@(map fourth meths))))
(define-macro (sortf op . places)
;; for mapcon emu...
(define (make-cdr-list lst)
(if (null? (cdr lst))
(list lst)
(cons lst (make-cdr-list (cdr lst)))))
(let* ((meths (map (lambda (p)
(call-with-values
(lambda _ (get-setf-method p)) list))
places))
(temps (apply append (map third meths))))
`(let* ,(map list
(append-map (lambda (m)
(append (first m)
(third m)))
meths)
(append-map (lambda (m)
(append (second m)
(list (fifth m))))
meths))
;; low level logic of sorting...
,@(append-map (lambda (rest)
(map (lambda (arg)
`(unless (,op ,(car rest) ,arg)
(rotatef ,(car rest) ,arg)))
(cdr rest)))
(make-cdr-list temps))
;; for set! effect.
,@(map fourth meths))))
gosh> (receive (x v i lst)
(values 10 #(1 2 3 4 5 6 7 8 9) 1 '(100 200 300))
(rotatef x (vector-ref v (inc! i)) (car lst))
(list x v lst))
*** ERROR: received fewer values than expected
Stack Trace:
_______________________________________
0 (let ((G168 (vector-ref v (inc! i)))) (receive (G169 G170 G171) (c ...
[unknown location]
関数でも書けるがマクロで書いた方が効率がよくなるもの、だそうだ。
すでに出て来た avg だが、それならここまで評価しても良さげに思う。
(define-macro (avg2 . args) `(/ ,(apply + args) ,(length args))) (define-macro (avg3 . args) `,(/ (apply + args) (length args)))
簡単な例だから関数と同じものに縮退しちゃった感じだ。 評価される時が違うだけ。
計算処理をコンパイル時にずらすだけでなく、 一部の計算処理すら回避する(場合もある)。
(define-macro (most-of . args)
(let ((need (floor (/ (length args) 2)))
(hits (gensym)))
`(let ((,hits 0))
(or ,@(map (lambda (a)
`(and ,a (> (inc! ,hits) ,need)))
args)))))
展開形の処理フローを追うと動作は分かるが、構成するのは結構つらい。 マクロ自体の造りはまだ分かってない。
(define-macro (nthmost n lst)
(if (and (integer? n) (< n 20))
(with-gensyms (glst gi)
(let ((syms (map0-n (lambda (x) (gensym)) n)))
`(let ((,glst ,lst))
(unless (< (length ,glst) ,(+ 1 n))
,@(gen-start glst syms)
(dolist (,gi ,glst)
,(nthmost-gen gi syms #t))
,(last syms)))))
`(nth ,n (sort (list-copy ,lst) >))))
(define (gen-start glst syms)
(define (make-cdr-list lst)
(if (null? (cdr lst))
(list lst)
(cons lst (make-cdr-list (cdr lst)))))
(reverse
(map (lambda (syms)
(let ((var (gensym)))
`(let ((,var (pop! ,glst)))
,(nthmost-gen var (reverse syms)))))
(make-cdr-list (reverse syms)))))
(define (nthmost-gen var vars . long?)
(if (null? vars)
'()
(let ((long? (get-optional long? #f)))
(let ((else (nthmost-gen var (cdr vars) long?)))
(if (and (not long?) (null? else))
`(setq ,(car vars) ,var)
`(if (> ,var ,(car vars))
(setq ,@(append-map list
(reverse vars)
(cdr (reverse vars)))
,(car vars) ,var)
,else))))))
あってるかどうか良く分からん。
なんかに出力して gnuplot なりなんなりで表示しないとどうなんだろうって感じ。
とりあえず、ロジック的な難解さは無いが、gauche.array を import してて
array の使い方が勉強になったくらいか。
あと、 (setter setter) ね。(srfi-17 のリファレンス実装参照)
なお、最初は *segs* *du* *pts* を define-constant ってしてたけど、
reload とかしてると 面倒だったので外した。
デバッグでは with-module とかの使い方も覚えて、
少しモジュールシステムも分かって来た気がする。
(define *segs* 20)
(define *du* (/ 1.0 *segs*))
(define *pts* (make-array (shape 0 *segs* 0 2)))
((setter setter) array-ref array-set!)
(define-macro (genbez x0 y0 x1 y1 x2 y2 x3 y3)
(with-gensyms (gx0 gx1 gy0 gy1 gx3 gy3)
`(let ((,gx0 ,x0) (,gy0 ,y0)
(,gx1 ,x1) (,gy1 ,y1)
(,gx3 ,x3) (,gy3 ,y3))
(let ((cx (* (- ,gx1 ,gx0) 3))
(cy (* (- ,gy1 ,gy0) 3))
(px (* (- ,x2 ,gx1) 3))
(py (* (- ,y2 ,gy1) 3)))
(let ((bx (- px cx))
(by (- py cy))
(ax (- ,gx3 px ,gx0))
(ay (- ,gy3 py ,gy0)))
(set! (,array-ref ,*pts* 0 0) ,gx0)
(set! (,array-ref ,*pts* 0 1) ,gy0)
,@(map1-n (lambda (n)
(let* ((u (* n *du*))
(u^2 (* u u))
(u^3 (expt u 3)))
`(begin
(set! (,array-ref ,*pts* ,n 0)
(+ (* ax ,u^3)
(* bx ,u^2)
(* cx ,u)
,gx0))
(set! (,array-ref ,*pts* ,n 1)
(+ (* ay ,u^3)
(* by ,u^2)
(* cy ,u)
,gy0)))))
(- *segs* 1))
(set! (,array-ref ,*pts* ,(- *segs* 1) 0) ,gx3)
(set! (,array-ref ,*pts* ,(- *segs* 1) 1) ,gy3))))))
前方参照と言われる概念を使う。 裏を返せば問題視していた変数捕捉の建設的な活用を狙ったもの、のようだ。
(define-macro (aif test-form then-form . else-form)
`(let ((it ,test-form))
(if it ,then-form ,@else-form)))
(define-macro (awhen test-form . body)
`(aif ,test-form
(begin ,@body)))
(define-macro (awhile expr . body)
`(do ((it ,expr ,expr))
((not it))
,@body))
(define-macro (aand . args)
(cond ((null? args) #t)
((null? (cdr args)) (car args))
(else `(aif ,(car args) (aand ,@(cdr args))))))
(define-macro (acond . clauses)
(if (null? clauses)
'()
(let ((cl1 (car clauses))
(sym (gensym)))
`(let ((,sym ,(car cl1)))
(if ,sym
(let ((it ,sym)) ,@(cdr cl1))
(acond ,@(cdr clauses)))))))
(define-macro (alambda parms . body)
`(letrec ((self (lambda ,parms ,@body)))
self))
(define-macro (ablock tag . args)
`(block ,tag
,((alambda (args)
(case (length args)
((0) '())
((1) (car args))
(else `(let ((it ,(car args)))
,(self (cdr args))))))
args)))
test 部が二値を返す版だ。
(define-macro (aif2 test . then-else)
(match then-else
((then . else)
(let ((win (gensym)))
`(receive (it ,win) ,test
(if (or it ,win) ,then ,@else))))))
(define-macro (awhen2 test . body)
`(aif2 ,test
(begin ,@body)))
(define-macro (awhile2 test . body)
(let ((flag (gensym)))
`(let ((,flag #t))
(while ,flag
(aif2 ,test
(begin ,@body)
(setq ,flag #f))))))
(define-macro (acond2 . clauses)
(if (null? clauses)
'()
(let ((cl1 (car clauses))
(val (gensym))
(win (gensym)))
`(receive (,val ,win) ,(car cl1)
(if (or ,val ,win)
(let ((it ,val)) ,@(cdr cl1))
(acond2 ,@(cdr clauses)))))))
(define-macro (fn expr) `,(rbuild expr))
(define (rbuild expr)
(if (or (symbol? expr) (eq? (car expr) 'lambda))
expr
(if (eq? (car expr) 'compose)
(build-compose (cdr expr))
(build-call (car expr) (cdr expr)))))
(define (build-call op fns)
(let ((g (gensym)))
`(lambda (,g)
(,op ,@(map (lambda (f)
`(,(rbuild f) ,g))
fns)))))
(define (build-compose fns)
(let ((g (gensym)))
`(lambda (,g)
,(letrec ((rec (lambda (fns)
(if (not (null? fns))
`(,(rbuild (car fns))
,(rec (cdr fns)))
g))))
(rec fns)))))
(define-macro (alrec rec . base)
(let1 base (get-optional base '())
(let ((gfn (gensym)))
`(lrec (lambda (it ,gfn)
(letrec ((rec (,gfn)))
,rec))
,base))))
(define-macro (on-cdrs rec base . lsts)
`((alrec ,rec (lambda _ ,base)) ,@lsts))
predicate 全般が () => #t となる scheme ではそもそも無理があるのだろうか? trec が悪いのか atrec が悪いのか on-trees かそれとも test コードか分からない。 現時点(2005/01/22 03:00:23 PST)では onlisp on-trees 6 が fail する。 追うのに疲れたので取り合えず出してみます。
(define-macro (atrec rec . base)
(let1 base (get-optional base 'it)
(let ((lfn (gensym)) (rfn (gensym)))
`(trec (lambda (it ,lfn ,rfn)
(letrec ((left (,lfn))
(right (,rfn)))
,rec))
(lambda (it) ,base)))))
(define-macro (on-trees rec base . trees)
`((atrec ,rec ,base) ,@trees))
delay/force だ。scheme には組み込みであるのでなんだけど、 やはりおもしろそうなので実装する。かなり雰囲気が違ってしまったが。
(define *unforced* (gensym))
(define (make-delay forced closure) (list forced closure))
(define (delay-forced x) (car x))
(define (delay-closure x) (cdr x))
;; Here, if you define like below.
;; (define delay-forced car)/(define delay-closure cdr)
;; Then you omit these setter's setting.
((setter setter) delay-forced set-car!)
((setter setter) delay-closure set-cdr!)
(define (delay? x)
(and (pair? x)
(eq? (car x) *unforced*)))
(define-macro (delay expr)
(let ((self (gensym)))
`(let ((,self (,make-delay *unforced* #f)))
(set! (,delay-closure ,self)
(lambda ()
(set! ,self ,expr)
,self))
,self)))
(define-macro (force x)
`(if (,delay? ,x)
(set! ,x ((,delay-closure ,x)))
,x))
test code がどうも test らしい test になってないが、この通り。
gosh> (use onlisp) (#<module onlisp> #<module gauche.interactive>) gosh> (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) fib gosh> (use gauche.time) (#<module gauche.time> #<module onlisp> #<module gauche.interactive>) gosh> (time (fib 35)) ;(time (fib 35)) ; real 6.782 ; user 6.770 ; sys 0.0-9 9227465 gosh> (define obj (delay (fib 35))) obj gosh> obj (G347 . #<closure 0x8413d80()>) ;;<= pair で実現した promise 実体 gosh> (time (force obj)) ;(time (force obj)) ; real 6.785 ; user 6.750 ; sys 0.000 9227465 gosh> obj 9227465 gosh> (force obj) 9227465 gosh> (time (force obj)) ;(time (force obj)) ; real 0.000 ; user 0.000 ; sys 0.000 9227465 gosh>
で、修正しました。
(define *unforced* (gensym))
(define (make-delay forced closure)
(cons forced closure))
(define delay-forced car)
(define delay-closure cdr)
(define (delay? p)
(if (and (pair? p)
(eq? (delay-forced p) *unforced*))
#t #f))
(define-macro (delay expr)
(let ((self (gensym)))
`(let ((,self (,make-delay *unforced* #f)))
(set! (,delay-closure ,self)
(lambda ()
(set! (,delay-forced ,self) ,expr)
(,delay-forced ,self)))
,self)))
(define (force x)
(if (delay? x)
((delay-closure x))
(delay-forced x)))
動作確認
gosh> (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) fib gosh> (time (fib 35)) ;(time (fib 35)) ; real 7.028 ; user 7.020 ; sys 0.000 9227465 gosh> (time (delay (fib 35))) ;(time (delay (fib 35))) ; real 0.000 ; user 0.000 ; sys 0.000 (G551 . #<closure 0x863b140()>) gosh> (time (force (delay (fib 35)))) ;(time (force (delay (fib 35)))) ; real 7.005 ; user 6.990 ; sys 0.0-9 9227465 gosh> (define obj (delay (fib 35))) obj gosh> obj (G551 . #<closure 0x863b100()>) gosh> (time (force obj)) ;(time (force obj)) ; real 7.067 ; user 7.030 ; sys 0.000 9227465 gosh> obj (9227465 . #<closure 0x863b100()>) gosh> (time (force obj)) ;(time (force obj)) ; real 0.000 ; user 0.000 ; sys 0.000 (9227465 . #<closure 0x863b100()>) gosh>
あと、テストはこんな感じでどうでしょう (foo が一回しか表示されない)
gosh> (define x (delay (begin (display 'foo) 1))) x gosh> (list (force x) (force x)) foo(1 1)
さあ、手がこんできたぞ。
#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[0] expected usage form.
(abbrev mvbind multiple-value-bind)
[1] [0] is extracted to this.
(define-macro (mvbind . args)
`(multiple-value-bind ,@args))
[2] abbrev's arguments take out backquote expression.
(define-macro (mvbind . args)
(let ((name 'multiple-value-bind))
`(,name ,@args)))
[3] rename abbrev's arguments.
`(define-macro (,short . args)
(let ((name ',long))
`(,name ,@args)))
[4] pull off names.
`(define-macro (,short . args)
`(,',long ,@args))
[5] finish.
(define-macro (abbrev short long)
`(define-macro (,short . args)
`(,',long ,@args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|#
(define-macro (abbrev short long)
`(define-macro (,short . args)
`(,',long ,@args)))
(define-macro (abbrevs . names)
`(begin
,@(map (lambda (pair)
`(abbrev ,@pair))
(group names 2))))
#|
[0]
(propmacro color)
[1]
(define-macro (color obj)
`(get ,obj 'color))
[2]
(define-macro (color obj)
(let ((name 'color))
`(get ,obj ',name)))
[3]
`(define-macro (,propname obj)
(let ((name ',propname))
`(get ,obj ',name)))
[4]
`(define-macro (,propname obj)
`(get ,obj ',',propname))
[5]
(define-macro (propmacro propname)
`(define-macro (,propname obj)
`(get ,obj ',',propname)))
|#
(define (get obj prop)
(cdr (assoc prop obj)))
(define-macro (propmacro propname)
`(define-macro (,propname obj)
`(get ,obj ',',propname)))
(define-macro (propmacros . names)
`(begin
,@(map (lambda (name)
`(propmacro ,name))
names)))
属性リストについては get だけモジュール内部で提供しよう。 …と思ったけど export せにゃならんか。
なお、 On Lisp にも書いてあるけど expand な下請けの関数は内部定義にすることが できるからそれもよい。分かりやすさから分離しているとのことだ。
まずは具体例から入る。 一度書いておくと何やってるか分かる。
(define-macro (a+ . args)
(a+expand args '()))
(define (a+expand args syms)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(a+expand (cdr args) (append syms (list sym)))))
`(+ ,@syms)))
(define-macro (alist . args)
(alist-expand args '()))
(define (alist-expand args syms)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(alist-expand (cdr args) (append syms (list sym)))))
`(list ,@syms)))
アナフォリックマクロを定義するマクロ
(define (pop-symbol sym)
(string->symbol (subseq (symbol->string sym) 1)))
;; calls is function like as +, list above examples.
;; if you don't write calls, you make a 'name'carefully.
;;
(define-macro (defanaph name . calls)
(let1 calls (get-optional calls #f)
(let ((calls (or calls (pop-symbol name))))
`(define-macro (,name . args)
(anaphex args (list ',calls))))))
(define (anaphex args expr)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(anaphex (cdr args) (append expr (list sym)))))
expr))
calls には + とか list とか最後に適用される関数を渡す。 もし指定しなければ name で与えたマクロ名の先頭一文字を削除したシンボルで あらわされる関数が適用されるので注意。
さらに一般化されたアナフォリックマクロを生成するマクロ。 ただし、call を指定する時にも :call キーワードを合わせて指定する必要あり、 let-keywords* 的にするか let-optionals* 的にするかってのは、 まぁ On Lisp 的にはあまり本質ではないが。
(define-macro (def-anaph name . calls-rule)
(let-keywords* calls-rule ((calls :call #f)
(rule :rule :all))
(let* ((opname (or calls (pop-symbol name)))
(body (case rule
((:all) `(anaphex1 args '(,opname)))
((:first) `(anaphex2 ',opname args))
((:place) `(anaphex3 ',opname args)))))
`(define-macro (,name . args)
,body))))
(define (anaphex1 args call)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(anaphex1 (cdr args)
(append call (list sym)))))
call))
(define (anaphex2 op args)
`(let ((it ,(car args))) (,op it ,@(cdr args))))
(define (anaphex3 op args)
`(_! (lambda (it) (,op it ,@(cdr args))) ,(car args)))
(define-macro (dbind pat seq . body)
(let ((gseq (gensym)))
`(let ((,gseq ,seq))
,(dbind-ex (destruc pat gseq atom?) body))))
(define (destruc pat seq . atom?-n)
(let-optionals* atom?-n ((pred atom?)
(n 0))
(if (null? pat)
'()
(let ((rest (cond ((pred pat) pat)
((eq? (car pat) :rest) (cadr pat))
((eq? (car pat) :body) (cadr pat))
(else '()))))
(if (not (null? rest))
`((,rest (,subseq ,seq ,n)))
(let ((p (car pat))
(rec (destruc (cdr pat) seq pred (+ n 1))))
(if (pred p)
(cons `(,p (ref ,seq ,n))
rec)
(let ((var (gensym)))
(cons (cons `(,var (ref ,seq ,n))
(destruc p var pred))
rec)))))))))
(define (dbind-ex binds body)
(if (null? binds)
`(begin ,@body)
`(let ,(map (lambda (b)
(if (pair? (car b))
(car b)
b))
binds)
,(dbind-ex (append-map (lambda (b)
(if (pair? (car b))
(cdr b) '()))
binds)
body))))
(define-macro (with-matrix pats ar . body)
(let ((gar (gensym)))
`(let ((,gar ,ar))
(let ,(let ((row -1))
(append-map
(lambda (pat)
(inc! row)
(setq col -1)
(map (lambda (p)
`(,p (,array-ref ,gar
,row
,(inc! col))))
pat))
pats))
,@body))))
(define-macro (with-array pat ar . body)
(let ((gar (gensym)))
`(let ((,gar ,ar))
(let ,(map (lambda (p)
`(,(car p) (,array-ref ,gar ,@(cdr p))))
pat)
,@body))))
シーケンスに対する構造化代入の参照渡し版だそうだが symbol-macrolet がないので
ちょっと意味がないね、これでは。
だが、今後多用されたら不便しそうってか実現できなそうだ。
On Lisp 内では (setf a 'uno) => (setf (ref g1 0) 'uno) などといった感じで使う。
setf 自体がマクロで第一引数を評価しないのにマクロ展開を噛ませるとなると、
かなり手強いので alrec や atrec の時みたいに (set! (a) 'uno) って
逃げる訳にもいかない気がする。
(define-macro (with-places pat seq . body)
(let ((gseq (gensym)))
`(let ((,gseq ,seq))
,(wplac-ex (destruc pat gseq) body))))
(define (wplac-ex binds body)
(if (null? binds)
`(begin ,@body)
`(letrec ,(map (lambda (b)
(if (pair? (car b))
(car b)
b))
binds)
,(wplac-ex (append-map (lambda (b)
(if (pair? (car b))
(cdr b)
'()))
binds)
body))))
基本の章も終了間近になって receive が multiple-value-bind と違うところに
アタリが出て来た。
multiple-value-bind の方は元より &rest 引数に多値を束縛してるんだね。
ということで急遽、寛容なreceiveであるreceive*を実装してみた。
さらに acond2 などのために receive を receive* の alias として置き換え。
これまで使ってた receive の置き換えをはかる。
一応 all test pass まで確認。
とりあえず、期待されている多値に足りないところには #f を返す様にしているが、
この辺は検討の余地があろう。
マクロを定義するマクロを書いてパラメタライズできそうなので、
本当に必要になれば手はあるはず。まぁ今はこだわるまい。
(define-macro (receive* forms expr . body)
(let ((gs (gensym)))
`(call-with-values (lambda _ ,expr)
(lambda ,gs
(apply (lambda ,forms ,@body)
(if (pair? ',forms)
(,take* ,gs (length ',forms) #t #f)
,gs))))))
まずはマッチング関数から。なんとなく返り値の仕様がいまいちになるが仕方無し。
(define (match-fn x y . binds)
(acond2
((or (eq? x y) (eq? x '_) (eq? y '_)) (values binds #t))
((binding x binds) (apply match-fn it y binds))
((binding y binds) (apply match-fn x it binds))
((varsym? x) (values (cons (cons x y) binds) #t))
((varsym? y) (values (cons (cons y x) binds) #t))
((and (pair? x) (pair? y) (apply match-fn (car x) (car y) binds))
(apply match-fn (cdr x) (cdr y) it))
(#t (values #f #f))))
(define (varsym? x)
(and (symbol? x) (equal? (string-ref (symbol->string x) 0) #\?)))
(define (binding x binds)
(letrec ((recbind (lambda (x binds)
(aif (assoc x binds)
(if it
(or (recbind (cdr it) binds) it))
it))))
(let ((b (recbind x binds)))
(values (if b (cdr b) b) b))))
高速マッチング・オペレータだけど、 r5rs では gensym はそもそも無いし、 通常のシンボルと識別する手段も自体ほとんどの実装が用意していないので、 gensym のインスタンスプールを保持する gensym として再定義する。 reload した場合にも original-gensym だけは守られる様に多少は気を使う。
(define-macro (if-match pat seq then . else)
(let1 else (get-optional else '())
`(let ,(map (lambda (v) `(,v ',(gensym)))
(vars-in pat simple?))
(pat-match ,pat ,seq ,then ,else))))
(define-macro (pat-match pat seq then else)
(if (simple? pat)
(match1 `((,pat ,seq)) then else)
(with-gensyms (gseq gelse)
`(letrec ((,gelse (lambda () ,else)))
,(gen-match (cons (list gseq seq)
(destruc pat gseq simple?))
then
`(,gelse))))))
(define (simple? x)
(or (atom? x) (eq? (car x) 'quote)))
(define (gen-match refs then else)
(if (null? refs)
then
(let ((then (gen-match (cdr refs) then else)))
(if (simple? (caar refs))
(match1 refs then else)
(gen-match (car refs) then else)))))
(define (match1 refs then else)
(dbind ((pat expr) . rest) refs
(cond ((gensym? pat)
`(let ((,pat ,expr))
(if (and (is-a? ,pat <sequence>)
,(length-test pat rest))
,then
,else)))
((eq? pat '_) then)
((var? pat)
(let ((ge (gensym)))
`(let ((,ge ,expr))
(if (or (,gensym? ,pat) (equal? ,pat ,ge))
(let ((,pat ,ge)) ,then)
,else))))
(else `(if (equal? ,pat ,expr) ,then ,else)))))
(define (gensym? s)
(and (symbol? s)
(not (eq? s (string->symbol (symbol->string s))))))
(define (length-test pat rest)
(define (last lst)
(if (null? lst) lst
(last-pair lst)))
(define (kaadar lst)
(if (null? lst)
lst
(caadar lst)))
(let ((fin (kaadar (last rest))))
(if (or (pair? fin) (eq? fin 'ref))
`(= (,size-of ,pat) ,(size-of rest))
`(> (,size-of ,pat) ,(- (size-of rest) 2)))))
とりあえず、基本編(勝手に区切るけど)は終了。
ここから先の章ではクエリ・コンパイラやPrologやオブジェクトシステムなどの
埋め込みのミニ言語実装に移る。
もちろん、ここまでのマクロ定義と埋め込みミニ言語との間に
明確な境界があるわけではないが、より大規模なものになるということ。
やるとしてもページを改めて、興味の湧いたテーマから個別に実装かな。
(define (gensym? s) (and (symbol? s) (not (eq? s (string->symbol (symbol->string s))))))
gosh> (define x (gensym)) x gosh> x G38 gosh> (eq? 'G38 x) #fこの結果を見て、上の方法が使えるのではと考えました。
(define-module onlisp
(use srfi-1)
(use srfi-17)
(use gauche.array)
(use gauche.sequence)
(use util.list)
(use util.match)
(extend simple-draw)
(export atom? gensym
complement compose memoize
fif fint fun
funcall lrec ttrav trec
nil! when while dolist when-bind block
sum1 sum avg with-redraw
bad-for for echo
nth orb our-let when-bind* with-gensyms
in inq in-if >case >casex
forever till do-tuples/o do-tuples/c
mvdo* mvdo mvpsetq setq allf mklist
symbol-value get-setf-method _! pull pull-if popn
rotatef sortf
most-of nthmost gen-start nthmost-gen genbez
aif awhen awhile aand acond alambda ablock
aif2 awhen2 awhile2 acond2
fn rbuild build-call build-compose
alrec on-cdrs atrec on-trees
delay force *unforced* delay?
abbrev abbrevs propmacro propmacros get
a+ a+expand alist alist-expand
defanaph anaphex pop-symbol
def-anaph anaphex1 anaphex2 anaphex3
dbind destruc dbind-ex with-matrix with-array
receive* receive
match-fn if-match-ls if-match pat-match
)
)
(select-module onlisp)
(define (complement pred)
(lambda args (not (apply pred args))))
(define (compose . fns)
(if (null? fns)
identity
(let ((fn1 (car (reverse fns)))
(fns (reverse (cdr (reverse fns)))))
(lambda args ((apply compose fns) (apply fn1 args))))))
(define (memoize fn)
(let ((cache (make-hash-table 'equal?)))
(lambda args
(if (hash-table-exists? cache args)
(hash-table-get cache args)
(let ((val (apply fn args)))
(hash-table-put! cache args val)
val)))))
(define (fif pred then . alt)
(lambda args
(if (apply pred args)
(apply then args)
(if (null? alt)
#f
(apply (car alt) args)))))
(define (fint fn . fns)
(if (null? fns)
fn
(lambda args
(and (apply fn args)
(apply (apply fint fns) args)))))
(define (fun fn . fns)
(if (null? fns)
fn
(lambda args
(or (apply fn args)
(apply (apply fun fns) args)))))
(define (funcall fn . args)
(apply fn args))
(define (lrec rec . base)
(letrec ((self (lambda (lst)
(if (null? lst)
(let ((base (get-optional base '())))
(if (procedure? base)
(base)
base))
(rec (car lst)
(lambda ()
(self (cdr lst))))))))
self))
(define atom? (compose not pair?))
(define not-null? (compose not null?))
(define (ttrav rec . base)
(let ((base (get-optional base identity)))
(letrec ((self (lambda (tree)
(if (atom? tree)
(if (procedure? base)
(base tree)
base)
(rec (self (car tree))
(if (not-null? (cdr tree))
(self (cdr tree)) '()))))))
self)))
(define (trec rec . base)
(let ((base (get-optional base identity)))
(letrec ((self (lambda (tree)
(if (atom? tree)
(if (procedure? base)
(base tree)
base)
(rec tree
(lambda ()
(self (car tree)))
(lambda ()
(self (cdr tree))))))))
self)))
(define-macro (nil! var) `(set! ,var #f))
(define-macro (when test . body)
`(if ,test (begin ,@body)))
(define-macro (while test . body)
`(do ()
((not ,test))
,@body))
(define-macro (dolist var-lst-res . body)
(match var-lst-res
((var lst . res)
`(begin
(map (lambda (,var) ,@body)
,lst)
(let ((,var '()))
,@res)))))
(define-macro (when-bind var-expr . body)
(match var-expr
((var expr)
`(let ((,var ,expr))
(when ,var ,@body)))))
(define-macro (block tag . body)
`(call/cc (lambda (,tag) ,@body)))
(define-macro (sum1 . args)
`(apply + (list ,@args)))
(define-macro (sum . args)
`(+ ,@args))
(define-macro (avg . args)
`(/ (+ ,@args) ,(length args)))
(define-macro (with-redraw var-objs . body)
(match var-objs
((var objs)
(let ((gob (gensym))
(x0 (gensym)) (y0 (gensym))
(x1 (gensym)) (y1 (gensym)))
`(let ((,gob ,objs))
(receive (,x0 ,y0 ,x1 ,y1) (bounds ,gob)
(dolist (,var ,gob) ,@body)
(receive (xa ya xb yb) (bounds ,gob)
(redraw (min ,x0 xa) (min ,y0 ya)
(max ,x1 xb) (max ,y1 yb)))))))))
(define-macro (bad-for var-start-stop . body)
(match var-start-stop
((var start stop)
`(do ((,var ,start (+ ,var 1))
(limit ,stop))
((> ,var limit))
,@body))))
(define-macro (for var-start-stop . body)
(match var-start-stop
((var start stop)
(let ((limit (gensym)))
`(do ((,var ,start (+ ,var 1))
(,limit ,stop))
((> ,var ,limit))
,@body)))))
(define-macro (echo . args)
`'(,@args amem))
(define-macro (nth n lst)
`(letrec ((nth-fn (lambda (n lst)
(if (= n 0)
(car lst)
(nth-fn (- n 1) (cdr lst))))))
(nth-fn ,n ,lst)))
(define-macro (orb . args)
(if (null? args)
#f
(let ((sym (gensym)))
`(let ((,sym ,(car args)))
(if ,sym
,sym
(orb ,@(cdr args)))))))
(define-macro (our-let binds . body)
`((lambda ,(map (lambda (x)
(if (pair? x) (car x) x))
binds)
,@body)
,@(map (lambda (x)
(if (pair? x) (cadr x) #f))
binds)))
(define-macro (when-bind* binds . body)
(if (null? binds)
`(begin ,@body)
`(let (,(car binds))
(if ,(caar binds)
(when-bind* ,(cdr binds) ,@body)))))
(define-macro (with-gensyms syms . body)
`(let ,(map (lambda (s)
`(,s (gensym)))
syms)
,@body))
(define-macro (in obj . choices)
(let ((insym (gensym)))
`(let ((,insym ,obj))
(or ,@(map (lambda (c) `(equal? ,insym ,c))
choices)))))
(define-macro (inq obj . args)
`(in ,obj ,@(map (lambda (a) `',a)
args)))
(define-macro (in-if fn . choices)
(let ((fnsym (gensym)))
`(let ((,fnsym ,fn))
(or ,@(map (lambda (c) `(,fnsym ,c))
choices)))))
(define-macro (>case expr . clauses)
(let ((g (gensym)))
`(let ((,g ,expr))
(cond ,@(map (lambda (cl) (>casex g cl))
clauses)))))
(define (>casex g cl)
(let ((key (car cl)) (rest (cdr cl)))
(cond ((pair? key) `((in ,g ,@key) ,@rest))
((inq key #t otherwise) `(#t ,@rest))
(else (error "bad >case clause")))))
(define-macro (forever . body)
`(do () (#f) ,@body))
(define-macro (till test . body)
`(do ()
(,test)
,@body))
(define (map0-n fn len)
(map fn (iota (+ len 1))))
(define (map1-n fn len)
(map fn (iota len 1)))
(define (nthcdr n lst)
(if (null? lst)
'()
(if (<= n 0)
lst
(nthcdr (- n 1) (cdr lst)))))
(define-macro (do-tuples/o parms source . body)
(if (not-null? parms)
(let ((src (gensym)))
`(let ((,src ,source))
(for-each (lambda ,parms ,@body)
,@(map0-n (lambda (n)
`(,nthcdr ,n ,src))
(- (length parms) 1)))))))
(define-macro (do-tuples/c parms source . body)
(if (not-null? parms)
(with-gensyms (src rest bodfn)
(let ((len (length parms)))
`(let ((,src ,source))
(when (,not-null? (,nthcdr ,(- len 1) ,src))
(letrec ((,bodfn (lambda ,parms ,@body)))
(do ((,rest ,src (cdr ,rest)))
((null? (,nthcdr ,(- len 1) ,rest))
,@(map (lambda (args)
`(,bodfn ,@args))
(dt-args len rest src))
#f)
(,bodfn ,@(map1-n (lambda (n)
`(nth ,(- n 1)
,rest))
len))))))))))
(define (dt-args len rest src)
(map0-n (lambda (m)
(map1-n (lambda (n)
(let ((x (+ m n)))
(if (>= x len)
`(nth ,(- x len) ,src)
`(nth ,(- x 1) ,rest))))
len))
(- len 2)))
(define-macro (mvdo* parm-cl test-cl . body)
(mvdo-gen parm-cl parm-cl test-cl body))
(define (mvdo-gen binds rebinds test body)
(if (null? binds)
(let ((label (gensym))
(return (gensym)))
`(block ,return
(let ,label ()
(if ,(car test)
(,return (begin ,@(cdr test))))
,@body
,@(mvdo-rebind-gen rebinds)
(,label))))
(let ((rec (mvdo-gen (cdr binds) rebinds test body)))
(let ((var/s (caar binds)) (expr (cadar binds)))
(if (not (pair? var/s))
`(let ((,var/s ,expr)) ,rec)
`(receive ,var/s ,expr ,rec))))))
(define (mvdo-rebind-gen rebinds)
(cond ((null? rebinds) '())
((< (length (car rebinds)) 3)
(mvdo-rebind-gen (cdr rebinds)))
(else (cons (list (if (not (pair? (caar rebinds)))
'set!
'set!-values)
(caar rebinds)
(list-ref (car rebinds) 2))
(mvdo-rebind-gen (cdr rebinds))))))
(define (mklist obj)
(if (list? obj) obj (list obj)))
(define (group source n)
(if (zero? n) (error "zero lenght"))
(letrec ((rec (lambda (source acc)
(let ((rest (drop* source n)))
(if (pair? rest)
(rec rest (cons (take source n) acc))
(reverse (cons source acc)))))))
(if (null? source) '() (rec source '()))))
(define (shuffle x y)
(cond ((null? x) y)
((null? y) x)
(else (list* (car x) (car y)
(shuffle (cdr x) (cdr y))))))
(define-macro (setq . args)
(if (null? args)
'()
(let ((pairs (group args 2)))
`(begin
,@(map (lambda (p)
`(guard (e (#t (eval `(define ,',(car p) ',,(cadr p))
(current-module))))
(set! ,@p)))
pairs)))))
(define-macro (mvpsetq . args)
(let* ((pairs (group args 2))
(syms (map (lambda (p)
(map (lambda _ (gensym))
(mklist (car p))))
pairs)))
(letrec ((rec (lambda (ps ss)
(if (null? ps)
`(setq ;; できれば ,setq として隠蔽したいが...
,@(append-map (lambda (p s)
(shuffle (mklist (car p))
s))
pairs syms))
(let ((body (rec (cdr ps) (cdr ss))))
(let ((var/s (caar ps))
(expr (cadar ps)))
(if (pair? var/s)
`(receive ,(car ss)
,expr
,body)
`(let ((,@(car ss) ,expr))
,body))))))))
(rec pairs syms))))
(define-macro (mvdo binds test-result . body)
(match test-result
((test . result)
(let ((label (gensym))
(return (gensym))
(temps (map (lambda (b)
(if (pair? (car b))
(map (lambda (x)
(gensym))
(car b))
(gensym)))
binds)))
`(let ,(map list
(append-map mklist temps)
(make-list (length (append-map mklist temps)) #f))
(mvpsetq ,@(append-map (lambda (b var)
(list var (cadr b)))
binds
temps))
(block ,return
(let ,(map (lambda (b var) (list b var))
(append-map mklist (map car binds))
(append-map mklist temps))
(let ,label ()
(if ,test
(,return (begin ,@result)))
,@body
(mvpsetq ,@(append-map (lambda (b)
(if (caddr b)
(list (car b)
(caddr b))))
binds))
(,label)))))))))
(define-macro (allf val . args)
(with-gensyms (gval)
`(let ((,gval ,val))
(setq ,@(append-map (lambda (a) (list a gval))
args)))))
(define-macro (symbol-value sym)
`(eval ,sym (current-module)))
(define (make-gensym n)
(if (= n 0) '() (cons (gensym) (make-gensym (- n 1)))))
(define (get-setf-method place)
(cond ((symbol? place)
(let ((g (gensym)))
(values '() '() (list g) `(set! ,place ,g) place)))
((pair? place)
(let* ((forms (cdr place))
(vars (make-gensym (length forms)))
(var (list (gensym)))
(set `((setter ,(car place)) ,@vars ,@var))
(access (cons (car place) vars)))
(values vars forms var set access)))))
(define-macro (_! op place . args)
(receive (vars forms var set access)
(get-setf-method place)
`(let* (,@(map list vars forms)
(,(car var) (,op ,access ,@args)))
,set)))
(define-macro (pull obj place . args)
(receive (vars forms var set access)
(get-setf-method place)
(let ((g (gensym)))
`(let* ((,g ,obj)
,@(map list vars forms)
(,(car var) (,delete ,g ,access ,@args)))
,set))))
(define-macro (pull-if test place)
(receive (vars forms var set access)
(get-setf-method place)
(let ((g (gensym)))
`(let* ((,g ,test)
,@(map list vars forms)
(,(car var) (,remove ,g ,access)))
,set))))
(define-macro (popn n place)
(receive (vars forms var set access)
(get-setf-method place)
(with-gensyms (gn glst)
`(let* ((,gn ,n)
,@(map list vars forms)
(,glst ,access)
(,(car var) (,nthcdr ,gn ,glst)))
(begin0 (,subseq ,glst ,gn)
,set)))))
(define-macro (rotatef . args)
(let* ((meths (map (lambda (p)
(call-with-values
(lambda _ (get-setf-method p)) list))
args))
(temps (apply append (map third meths))))
`(let* ,(map list
(append-map (lambda (m)
(append (first m)
(third m)))
meths)
(append-map (lambda (m)
(append (second m)
(list (fifth m))))
meths))
;; rotate logic...
(mvpsetq ,@(append-map list temps (cdr temps))
,(last temps) ,(car temps))
;; for set! effect.
,@(map fourth meths))))
(define-macro (sortf op . places)
;; for mapcon emu...
(define (make-cdr-list lst)
(if (null? (cdr lst))
(list lst)
(cons lst (make-cdr-list (cdr lst)))))
(let* ((meths (map (lambda (p)
(call-with-values
(lambda _ (get-setf-method p)) list))
places))
(temps (apply append (map third meths))))
`(let* ,(map list
(append-map (lambda (m)
(append (first m)
(third m)))
meths)
(append-map (lambda (m)
(append (second m)
(list (fifth m))))
meths))
;; low level logic of sorting...
,@(append-map (lambda (rest)
(map (lambda (arg)
`(unless (,op ,(car rest) ,arg)
(rotatef ,(car rest) ,arg)))
(cdr rest)))
(make-cdr-list temps))
;; for set! effect.
,@(map fourth meths))))
(define-macro (most-of . args)
(let ((need (floor (/ (length args) 2)))
(hits (gensym)))
`(let ((,hits 0))
(or ,@(map (lambda (a)
`(and ,a (> (inc! ,hits) ,need)))
args)))))
(define-macro (nthmost n lst)
(if (and (integer? n) (< n 20))
(with-gensyms (glst gi)
(let ((syms (map0-n (lambda (x) (gensym)) n)))
`(let ((,glst ,lst))
(unless (< (length ,glst) ,(+ 1 n))
,@(gen-start glst syms)
(dolist (,gi ,glst)
,(nthmost-gen gi syms #t))
,(last syms)))))
`(nth ,n (sort (list-copy ,lst) >))))
(define (gen-start glst syms)
(define (make-cdr-list lst)
(if (null? (cdr lst))
(list lst)
(cons lst (make-cdr-list (cdr lst)))))
(reverse
(map (lambda (syms)
(let ((var (gensym)))
`(let ((,var (pop! ,glst)))
,(nthmost-gen var (reverse syms)))))
(make-cdr-list (reverse syms)))))
(define (nthmost-gen var vars . long?)
(if (null? vars)
'()
(let ((long? (get-optional long? #f)))
(let ((else (nthmost-gen var (cdr vars) long?)))
(if (and (not long?) (null? else))
`(setq ,(car vars) ,var)
`(if (> ,var ,(car vars))
(setq ,@(append-map list
(reverse vars)
(cdr (reverse vars)))
,(car vars) ,var)
,else))))))
(define *segs* 20)
(define *du* (/ 1.0 *segs*))
(define *pts* (make-array (shape 0 *segs* 0 2)))
((setter setter) array-ref array-set!)
(define-macro (genbez x0 y0 x1 y1 x2 y2 x3 y3)
(with-gensyms (gx0 gx1 gy0 gy1 gx3 gy3)
`(let ((,gx0 ,x0) (,gy0 ,y0)
(,gx1 ,x1) (,gy1 ,y1)
(,gx3 ,x3) (,gy3 ,y3))
(let ((cx (* (- ,gx1 ,gx0) 3))
(cy (* (- ,gy1 ,gy0) 3))
(px (* (- ,x2 ,gx1) 3))
(py (* (- ,y2 ,gy1) 3)))
(let ((bx (- px cx))
(by (- py cy))
(ax (- ,gx3 px ,gx0))
(ay (- ,gy3 py ,gy0)))
(set! (,array-ref ,*pts* 0 0) ,gx0)
(set! (,array-ref ,*pts* 0 1) ,gy0)
,@(map1-n (lambda (n)
(let* ((u (* n *du*))
(u^2 (* u u))
(u^3 (expt u 3)))
`(begin
(set! (,array-ref ,*pts* ,n 0)
(+ (* ax ,u^3)
(* bx ,u^2)
(* cx ,u)
,gx0))
(set! (,array-ref ,*pts* ,n 1)
(+ (* ay ,u^3)
(* by ,u^2)
(* cy ,u)
,gy0)))))
(- *segs* 1))
(set! (,array-ref ,*pts* ,(- *segs* 1) 0) ,gx3)
(set! (,array-ref ,*pts* ,(- *segs* 1) 1) ,gy3))))))
(define-macro (aif test-form then-form . else-form)
`(let ((it ,test-form))
(if it ,then-form ,@else-form)))
(define-macro (awhen test-form . body)
`(aif ,test-form
(begin ,@body)))
(define-macro (awhile expr . body)
`(do ((it ,expr ,expr))
((not it))
,@body))
(define-macro (aand . args)
(cond ((null? args) #t)
((null? (cdr args)) (car args))
(else `(aif ,(car args) (aand ,@(cdr args))))))
(define-macro (acond . clauses)
(if (null? clauses)
'()
(let ((cl1 (car clauses))
(sym (gensym)))
`(let ((,sym ,(car cl1)))
(if ,sym
(let ((it ,sym)) ,@(cdr cl1))
(acond ,@(cdr clauses)))))))
(define-macro (alambda parms . body)
`(letrec ((self (lambda ,parms ,@body)))
self))
(define-macro (ablock tag . args)
`(block ,tag
,((alambda (args)
(case (length args)
((0) '())
((1) (car args))
(else `(let ((it ,(car args)))
,(self (cdr args))))))
args)))
(define-macro (aif2 test . then-else)
(match then-else
((then . else)
(let ((win (gensym)))
`(receive (it ,win) ,test
(if (or it ,win) ,then ,@else))))))
(define-macro (awhen2 test . body)
`(aif2 ,test
(begin ,@body)))
(define-macro (awhile2 test . body)
(let ((flag (gensym)))
`(let ((,flag #t))
(while ,flag
(aif2 ,test
(begin ,@body)
(setq ,flag #f))))))
(define-macro (acond2 . clauses)
(if (null? clauses)
'()
(let ((cl1 (car clauses))
(val (gensym))
(win (gensym)))
`(receive (,val ,win) ,(car cl1)
(if (or ,val ,win)
(let ((it ,val)) ,@(cdr cl1))
(acond2 ,@(cdr clauses)))))))
(define-macro (fn expr) `,(rbuild expr))
(define (rbuild expr)
(if (or (symbol? expr) (eq? (car expr) 'lambda))
expr
(if (eq? (car expr) 'compose)
(build-compose (cdr expr))
(build-call (car expr) (cdr expr)))))
(define (build-call op fns)
(let ((g (gensym)))
`(lambda (,g)
(,op ,@(map (lambda (f)
`(,(rbuild f) ,g))
fns)))))
(define (build-compose fns)
(let ((g (gensym)))
`(lambda (,g)
,(letrec ((rec (lambda (fns)
(if (not (null? fns))
`(,(rbuild (car fns))
,(rec (cdr fns)))
g))))
(rec fns)))))
(define-macro (alrec rec . base)
(let1 base (get-optional base '())
(let ((gfn (gensym)))
`(lrec (lambda (it ,gfn)
(letrec ((rec (lambda () (,gfn))))
,rec))
,base))))
(define-macro (on-cdrs rec base . lsts)
`((alrec ,rec (lambda _ ,base)) ,@lsts))
(define-macro (atrec rec . base)
(let1 base (get-optional base 'it)
(let ((lfn (gensym)) (rfn (gensym)))
`(trec (lambda (it ,lfn ,rfn)
(letrec ((left (lambda () (,lfn)))
(right (lambda () (,rfn))))
,rec))
(lambda (it) ,base)))))
(define-macro (on-trees rec base . trees)
`((atrec ,rec ,base) ,@trees))
#|
; R5RS like
(define (force obj) (obj))
(define-macro (delay expr)
`(make-promise (lambda () ,expr)))
(define (make-promise proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result-ready? #t)
(set! result x)
result)))))))
|#
(define *unforced* (gensym))
(define (make-delay forced closure)
(cons forced closure))
(define delay-forced car)
(define delay-closure cdr)
(define (delay? p)
(if (and (pair? p)
(eq? (delay-forced p) *unforced*))
#t #f))
(define-macro (delay expr)
(let ((self (gensym)))
`(let ((,self (,make-delay *unforced* #f)))
(set! (,delay-closure ,self)
(lambda ()
(set! (,delay-forced ,self) ,expr)
(,delay-forced ,self)))
,self)))
(define (force x)
(if (delay? x)
((delay-closure x))
(delay-forced x)))
#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[0] expected usage form.
(abbrev mvbind multiple-value-bind)
[1] [0] is extracted to this.
(define-macro (mvbind . args)
`(multiple-value-bind ,@args))
[2] abbrev's arguments take out backquote expression.
(define-macro (mvbind . args)
(let ((name 'multiple-value-bind))
`(,name ,@args)))
[3] rename abbrev's arguments.
`(define-macro (,short . args)
(let ((name ',long))
`(,name ,@args)))
[4] pull off names.
`(define-macro (,short . args)
`(,',long ,@args))
[5] finish.
(define-macro (abbrev short long)
`(define-macro (,short . args)
`(,',long ,@args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|#
(define-macro (abbrev short long)
`(define-macro (,short . args)
`(,',long ,@args)))
(define-macro (abbrevs . names)
`(begin
,@(map (lambda (pair)
`(abbrev ,@pair))
(group names 2))))
#|
[0]
(propmacro color)
[1]
(define-macro (color obj)
`(get ,obj 'color))
[2]
(define-macro (color obj)
(let ((name 'color))
`(get ,obj ',name)))
[3]
`(define-macro (,propname obj)
(let ((name ',propname))
`(get ,obj ',name)))
[4]
`(define-macro (,propname obj)
`(get ,obj ',',propname))
[5]
(define-macro (propmacro propname)
`(define-macro (,propname obj)
`(get ,obj ',',propname)))
|#
(define (get obj prop)
(cdr (assoc prop obj)))
(define-macro (propmacro propname)
`(define-macro (,propname obj)
`(get ,obj ',',propname)))
(define-macro (propmacros . names)
`(begin
,@(map (lambda (name)
`(propmacro ,name))
names)))
(define-macro (a+ . args)
(a+expand args '()))
(define (a+expand args syms)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(a+expand (cdr args) (append syms (list sym)))))
`(+ ,@syms)))
(define-macro (alist . args)
(alist-expand args '()))
(define (alist-expand args syms)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(alist-expand (cdr args) (append syms (list sym)))))
`(list ,@syms)))
(define (pop-symbol sym)
(string->symbol (subseq (symbol->string sym) 1)))
;; calls is function like as +, list above examples.
;; if you don't write calls, you make a 'name'carefully.
;;
(define-macro (defanaph name . calls)
(let1 calls (get-optional calls #f)
(let ((calls (or calls (pop-symbol name))))
`(define-macro (,name . args)
(anaphex args (list ',calls))))))
(define (anaphex args expr)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(anaphex (cdr args) (append expr (list sym)))))
expr))
(define-macro (def-anaph name . calls-rule)
(let-keywords* calls-rule ((calls :call #f)
(rule :rule :all))
(let* ((opname (or calls (pop-symbol name)))
(body (case rule
((:all) `(anaphex1 args '(,opname)))
((:first) `(anaphex2 ',opname args))
((:place) `(anaphex3 ',opname args)))))
`(define-macro (,name . args)
,body))))
(define (anaphex1 args call)
(if (not (null? args))
(let ((sym (gensym)))
`(let* ((,sym ,(car args))
(it ,sym))
,(anaphex1 (cdr args)
(append call (list sym)))))
call))
(define (anaphex2 op args)
`(let ((it ,(car args))) (,op it ,@(cdr args))))
(define (anaphex3 op args)
`(_! (lambda (it) (,op it ,@(cdr args))) ,(car args)))
(define-macro (dbind pat seq . body)
(let ((gseq (gensym)))
`(let ((,gseq ,seq))
,(dbind-ex (destruc pat gseq atom?) body))))
(define (destruc pat seq . atom?-n)
(let-optionals* atom?-n ((pred atom?)
(n 0))
(if (null? pat)
'()
(let ((rest (cond ((pred pat) pat)
((eq? (car pat) :rest) (cadr pat))
((eq? (car pat) :body) (cadr pat))
(else '()))))
(if (not (null? rest))
`((,rest (,subseq ,seq ,n)))
(let ((p (car pat))
(rec (destruc (cdr pat) seq pred (+ n 1))))
(if (pred p)
(cons `(,p (ref ,seq ,n))
rec)
(let ((var (gensym)))
(cons (cons `(,var (ref ,seq ,n))
(destruc p var pred))
rec)))))))))
(define (dbind-ex binds body)
(if (null? binds)
`(begin ,@body)
`(let ,(map (lambda (b)
(if (pair? (car b))
(car b)
b))
binds)
,(dbind-ex (append-map (lambda (b)
(if (pair? (car b))
(cdr b) '()))
binds)
body))))
(define-macro (with-matrix pats ar . body)
(let ((gar (gensym)))
`(let ((,gar ,ar))
(let ,(let ((row -1))
(append-map
(lambda (pat)
(inc! row)
(setq col -1)
(map (lambda (p)
`(,p (,array-ref ,gar
,row
,(inc! col))))
pat))
pats))
,@body))))
(define-macro (with-array pat ar . body)
(let ((gar (gensym)))
`(let ((,gar ,ar))
(let ,(map (lambda (p)
`(,(car p) (,array-ref ,gar ,@(cdr p))))
pat)
,@body))))
#|
;; I want to use symbol-macrolet.
;;
(define-macro (with-places pat seq . body)
(let ((gseq (gensym)))
`(let ((,gseq ,seq))
,(wplac-ex (destruc pat gseq) body))))
(define (wplac-ex binds body)
(if (null? binds)
`(begin ,@body)
`(letrec ,(map (lambda (b)
(if (pair? (car b))
(car b)
b))
binds)
,(wplac-ex (append-map (lambda (b)
(if (pair? (car b))
(cdr b)
'()))
binds)
body))))
|#
(define-macro (receive* forms expr . body)
(let ((gs (gensym)))
`(call-with-values (lambda _ ,expr)
(lambda ,gs
(apply (lambda ,forms ,@body)
(if (pair? ',forms)
(,take* ,gs (length ',forms) #t #f)
,gs))))))
(define receive receive*)
(define (match-fn x y . binds)
(acond2
((or (eq? x y) (eq? x '_) (eq? y '_)) (values binds #t))
((binding x binds) (apply match-fn it y binds))
((binding y binds) (apply match-fn x it binds))
((varsym? x) (values (cons (cons x y) binds) #t))
((varsym? y) (values (cons (cons y x) binds) #t))
((and (pair? x) (pair? y) (apply match-fn (car x) (car y) binds))
(apply match-fn (cdr x) (cdr y) it))
(#t (values #f #f))))
(define (varsym? x)
(and (symbol? x) (equal? (string-ref (symbol->string x) 0) #\?)))
(define (binding x binds)
(letrec ((recbind (lambda (x binds)
(aif (assoc x binds)
(if it
(or (recbind (cdr it) binds) it))
it))))
(let ((b (recbind x binds)))
(values (if b (cdr b) b) b))))
(define-macro (if-match-ls pat seq then . else)
(let1 else (get-optional else '())
`(aif2 (match-fn ',pat ,seq)
(let ,(map (lambda (v)
`(,v (,binding ',v it)))
(vars-in then atom?))
,then)
,else)))
(define (vars-in expr . pred)
(let1 pred (get-optional pred atom?)
(if (pred expr)
(if (var? expr) (list expr) '())
(lset-union eq? (vars-in (car expr) atom?)
(vars-in (cdr expr) atom?)))))
(define (var? x)
(and (symbol? x) (eq? (string-ref (symbol->string x) 0) #\?)))
;; -- if-match macro --
;; special define for gensym? procedure.
;;
#|
(define original-gensym
(if (symbol-bound? 'original-gensym)
original-gensym
gensym))
(define gensym
(let ((*gensyms* '()))
(lambda args
(cond
((null? args)
(begin
(set! *gensyms* (cons (original-gensym) *gensyms*))
(car *gensyms*)))
((string? (car args))
(begin
(set! *gensyms* (cons (apply original-gensym args) *gensyms*))
(car *gensyms*)))
((eq? 'syms (car args)) *gensyms*)
(else (error "ERROR: gensym has no such message." args))))))
(define (gensym? s)
(if (member s (gensym 'syms) eq?)
#t #f))
|#
(define-macro (if-match pat seq then . else)
(let1 else (get-optional else '())
`(let ,(map (lambda (v) `(,v ',(gensym)))
(vars-in pat simple?))
(pat-match ,pat ,seq ,then ,else))))
(define-macro (pat-match pat seq then else)
(if (simple? pat)
(match1 `((,pat ,seq)) then else)
(with-gensyms (gseq gelse)
`(letrec ((,gelse (lambda () ,else)))
,(gen-match (cons (list gseq seq)
(destruc pat gseq simple?))
then
`(,gelse))))))
(define (simple? x)
(or (atom? x) (eq? (car x) 'quote)))
(define (gen-match refs then else)
(if (null? refs)
then
(let ((then (gen-match (cdr refs) then else)))
(if (simple? (caar refs))
(match1 refs then else)
(gen-match (car refs) then else)))))
(define (match1 refs then else)
(dbind ((pat expr) . rest) refs
(cond ((gensym? pat)
`(let ((,pat ,expr))
(if (and (is-a? ,pat <sequence>)
,(length-test pat rest))
,then
,else)))
((eq? pat '_) then)
((var? pat)
(let ((ge (gensym)))
`(let ((,ge ,expr))
(if (or (,gensym? ,pat) (equal? ,pat ,ge))
(let ((,pat ,ge)) ,then)
,else))))
(else `(if (equal? ,pat ,expr) ,then ,else)))))
(define (gensym? s)
(and (symbol? s)
(not (eq? s (string->symbol (symbol->string s))))))
(define (length-test pat rest)
(define (last lst)
(if (null? lst) lst
(last-pair lst)))
(define (kaadar lst)
(if (null? lst)
lst
(caadar lst)))
(let ((fin (kaadar (last rest))))
(if (or (pair? fin) (eq? fin 'ref))
`(= (,size-of ,pat) ,(size-of rest))
`(> (,size-of ,pat) ,(- (size-of rest) 2)))))
(provide "onlisp")
;; Local variables:
;; mode: scheme
;; end:
(use gauche.test)
(test-start "onlisp")
(use srfi-1)
(use gauche.array)
(use gauche.sequence)
(use equal-expr)
(use onlisp)
(test-module 'onlisp)
(test-section "onlisp section 1")
(test* "onlisp complement 1" #t
((complement pair?) '()))
(test* "onlisp complement 2" '(#t #f #t #f #t #f #t #f #t #f)
(map (complement odd?) (iota 10)))
(test* "onlisp compose 1" (map (lambda (x) (expt x 2)) (iota 10 1))
(map (compose (lambda (x) (* x x))
(lambda (x) (+ x 1)))
(iota 10)))
(test* "onlisp compose 2" #f
((compose not null?) '()))
(test* "onlisp compose 3" #t
((compose not procedure?) #f))
(test* "onlisp lrec 1" 10
((lrec (lambda (x f) (+ 1 (f))) 0) (iota 10)))
(test* "onlisp lrec 2" #f
((lrec (lambda (x f) (and (odd? x) (f))) #t) (iota 10)))
(test* "onlisp lrec 3" #t
((lrec (lambda (x f) (and (number? x) (f))) #t) (iota 10)))
(test* "onlisp lrec 4" (iota 10)
((lrec (lambda (x f) (cons x (f)))) (iota 10)))
(test* "onlisp lrec 5" #f
(let ((x (iota 10)))
(eq? x ((lrec (lambda (x f) (cons x (f)))) x))))
(test* "onlisp ttrav 1" (iota 10)
((ttrav cons identity) (iota 10)))
(test* "onlisp ttrav 2" (iota 10)
((ttrav cons) (iota 10)))
(test "onlisp ttrav 3" 10
(lambda ()
(define not-last? (compose not null?))
((ttrav (lambda (l r) (+ l (if (not-last? r) r 1))) 1) '((a b (c d)) (e) f))))
(test "onlisp ttrav 4" 6
(lambda ()
(define not-last? (compose not null?))
((ttrav (lambda (l r) (+ l (if (not-last? r) r 0))) 1) '((a b (c d)) (e) f))))
(test* "onlisp ttrav 5" '(1 2 3)
((ttrav append! list) '((1 2) 3)))
(test* "onlisp trec 1" 3
((trec (lambda (o l r) (or (l) (r)))
(lambda (tree) (and (odd? tree) tree)))
'(0 2 3 4 5 6 7)))
(test* "onlisp trec 2" '()
((trec (lambda (o l r) (or (l) (r)))
(lambda (tree) (and ((compose not procedure?) tree) tree)))
(list + - * /)))
(test* "onlisp trec 3" '(1 2 3)
((trec (lambda (o l r) (append! (l) (r))) mklist)
'((1 2) 3)))
(test-section "onlisp section 2")
(test "onlisp nil! 1" #f
(lambda ()
(define x #t) (nil! x) x))
(test* "onlisp when 1" '(if #f (begin #t))
(%macroexpand-1 (when #f #t)))
(test* "onlisp when 2" #f
(when #t #f))
(test* "onlisp while 1" (apply + (iota 10 1))
(let ((x 10)
(sum 0))
(while (>= x 0)
(set! sum (+ sum x))
(dec! x))
sum))
(test* "onlisp dolist 1" '(begin
(map (lambda (x) (print x))
'(a b c))
(let ((x '()))))
(%macroexpand-1 (dolist (x '(a b c)) (print x))))
(test* "onlisp dolist 2" '(begin
(map (lambda (x) (print x))
'(a b c))
(let ((x '()))
'result-value))
(%macroexpand-1 (dolist (x '(a b c) 'result-value) (print x))))
(test* "onlisp dolist 3" '()
(dolist (x '(1 2 3 4 5) x)
(format #f "~a" x)))
(test* "onlisp dolist 4" (apply + (iota 10 1))
(let ((sum 0))
(dolist (x (iota 10 1) sum)
(set! sum (+ sum x)))))
(test* "onlisp when-bind 1" '(use gauche.test)
(when-bind (port (open-input-file "./test-onlisp.scm"))
(read port)))
(test* "onlisp sum1 1" '(apply + (list 1 2 3 4 5))
(%macroexpand-1 (sum1 1 2 3 4 5)))
(test* "onlisp sum1 2" 15
(sum1 1 2 3 4 5))
(test* "onlisp sum 1" '(+ 1 2 3 4 5)
(%macroexpand-1 (sum 1 2 3 4 5)))
(test* "onlisp sum 2" 15
(sum 1 2 3 4 5))
(test* "onlisp avg 1" '(/ (+ 1 2 3 4 5) 5)
(%macroexpand-1 (avg 1 2 3 4 5)))
(test* "onlisp avg 2" 3
(avg 1 2 3 4 5))
(test* "onlisp avg 3" 3
(avg 1 2 3 (* 2 2) (+ 2 3)))
;;======================================
;; sample objs
(define obj1
(make <line>
:start (make <point> :x 3 :y 13)
:end (make <point> :x -7 :y 8)))
(define obj2
(make <line>
:start (make <point> :x 16 :y -6)
:end (make <point> :x 9 :y 1)))
(define obj3
(make <line>
:start (make <point> :x -12 :y 8)
:end (make <point> :x 11 :y -2)))
;; I've no idea for testing with-draw macro
(test* "onlisp for 1" "12345678910"
(with-output-to-string
(lambda ()
(for (i 1 10) (write i)))))
(test* "onlisp for 2" "3628800"
(with-output-to-string
(lambda ()
(let ((sum 1))
(for (limit 1 10)
(set! sum (* sum limit)))
(write sum)))))
(test* "onlisp for 3" '(do ((x 1 (+ x 1))
(limit 10)) ((> x limit))
(* x x))
(%macroexpand-1 (for (x 1 10) (* x x)))
equal-expr?)
(test* "onlisp echo 1" '(Bill amem)
(echo Bill))
(test* "onlisp echo 2" '(Bill amem)
(let ((fn (lambda () (echo Bill))))
(fn)
(fn)))
(test* "onlisp nth 1" 5
(nth 5 (iota 10)))
(test* "onlisp nth 2" '(letrec ((nth-fn (lambda (n lst)
(if (= n 0)
(car lst)
(nth-fn (- n 1) (cdr lst))))))
(nth-fn 5 (iota 10)))
(%macroexpand-1 (nth 5 (iota 10))))
(test* "onlisp orb 1" #f
(orb #f #f #f #f #f))
(test* "onlisp orb 2" "Hello"
(orb #f #f "Hello" #f #f #t))
(test* "onlisp orb 3" '(let ((sym #f))
(if sym
sym
(orb #f "OK" #f #f)))
(%macroexpand-1 (orb #f #f "OK" #f #f))
equal-expr?)
(test* "onlisp our-let 1" (* 10 20)
(our-let ((x 10)
(y 20))
(* x y)))
(test* "onlisp our-let 2" (+ (* 3 3) (* 4 4))
(our-let ((f (lambda (x) (* x x)))
(g (lambda (x y) (+ x y)))
(x 3)
(y 4))
(g (f x) (f y))))
(test* "onlisp our-let 3" '((lambda (x y) (* x y)) 3 4)
(%macroexpand-1 (our-let ((x 3) (y 4))
(* x y)))
equal-expr?)
(test* "onlisp when-bind* 1" '(#t #f #t #f #t)
(when-bind* ((f? even?)
(g? (complement f?)))
(map g? '(1 2 3 4 5))))
(test* "onlisp with-gensyms 1" '(let ((a (gensym))
(b (gensym))
(c (gensym))
(d (gensym))
(e (gensym)))
(list a b c d e))
(%macroexpand-1 (with-gensyms (a b c d e)
(list a b c d e)))
equal-expr?)
(test* "onlisp in 1" #t
(in 5 1 2 3 4 5 6 7 8 9 10))
(test* "onlisp in 2" #t
(in 'bar 'foo 'bar 'goo))
(test* "onlisp inq 1" #t
(inq 'bar foo bar goo))
(test* "onlisp inq 2" #f
(inq 'goo foo bar))
(test* "onlisp in-if 1" #t
(in-if (lambda (c) (equal? c 5)) 1 2 3 4 5 (apply / '(1 0)) 6 7 8 9))
(test* "onlisp >case 1" "big!"
(>case (+ 1 2 3)
((0 1 2 3 4) "small!")
((5 6 7 8 9) "big!")))
(test* "onlisp >case 2" "get bar"
(>case (cadr '(foo bar goo))
(('foo) "get foo")
(('bar) "get bar")
(('goo) "get goo")))
(test* "onlisp >case 3" "Not found"
(>case (cadr '(foo moo bar goo))
(('foo) "get foo")
(('bar) "get bar")
(('goo) "get goo")
(#t "Not found")))
(test* "onlisp >case 4" "Not found"
(>case (cadr '(foo moo bar goo))
(('foo) "get foo")
(('bar) "get bar")
(('goo) "get goo")
(otherwise "Not found")))
(test* "onlisp forever 1" '(do () (#f)
(print "Hello!")
(print "Bye!"))
(%macroexpand-1 (forever (print "Hello!")
(print "Bye!"))))
(test* "onlisp till 1" 10000
(let ((x 1))
(till (>= x 10000) (inc! x)) x))
(test* "onlisp do-tuples/o 1" '((a b) (b c) (c d) (d e) (e f) (f g))
(let ((res '()))
(do-tuples/o (x y) '(a b c d e f g)
(set! res (cons (list x y) res)))
(reverse res)))
(test* "onlisp do-tuples/o 2" '(a b c d e f g)
(let ((res '()))
(do-tuples/o (x) '(a b c d e f g)
(set! res (cons x res)))
(reverse res)))
(test* "onlisp do-tuples/o 3" '((a b c) (b c d) (c d e) (d e f) (e f g))
(let ((res '()))
(do-tuples/o (x y z) '(a b c d e f g)
(set! res (cons (list x y z) res)))
(reverse res)))
(test* "onlisp do-tuples/c 1" '((a b) (b c) (c d) (d e) (e f) (f g) (g a))
(let ((res '()))
(do-tuples/c (x y) '(a b c d e f g)
(set! res (cons (list x y) res)))
(reverse res)))
(test* "onlisp do-tuples/c 2" '(a b c d e f g)
(let ((res '()))
(do-tuples/c (x) '(a b c d e f g)
(set! res (cons x res)))
(reverse res)))
(test* "onlisp do-tuples/c 3" '((a b c) (b c d) (c d e) (d e f) (e f g) (f g a) (g a b))
(let ((res '()))
(do-tuples/c (x y z) '(a b c d e f g)
(set! res (cons (list x y z) res)))
(reverse res)))
(test* "onlisp mvdo* 1" '(block return
(let loop ()
(if #t (return (begin 'done)))
(loop)))
(%macroexpand-1
(mvdo* () (#t 'done)))
equal-expr?)
(test* "onlisp mvdo* 2" 'done
(mvdo* () (#t 'done)))
(test* "onlisp mvdo* 3" 10
(mvdo* (((x y) (values 1 2) (values (+ x 1) (+ y 1))))
((>= x 9) y)))
(test* "onlisp mvdo* 4" '(20 20 #t #f)
(mvdo* (((x y) (values 100 -100) (values (- x 2) (+ y 3)))
((a b) (values #t #f) (values (not a) (not b))))
((<= x y) (list x y a b))))
(test* "onlisp mvdo* 5" 8
(mvdo* ((x 1 (+ x 1))
(y 10 (+ y 1))
(i 0))
((>= (* x 2) y) i)
(inc! i)))
(test* "onlisp mvdo* 6" '(6 5 6)
(mvdo* ((x 1 (+ 1 x))
((y z) (values 0 0) (values z x)))
((> x 5) (list x y z))
(format #f "~a" (list x y z))))
(test* "onlisp mvdo* 7" "(1 0 0)(2 0 2)(3 2 3)(4 3 4)(5 4 5)"
(with-output-to-string
(lambda ()
(mvdo* ((x 1 (+ 1 x))
((y z) (values 0 0) (values z x)))
((> x 5) (list x y z))
(write (list x y z))))))
(test* "onlisp mvpsetq 1" '(a b 0 1)
(let ((w 0) (x 1) (y 2) (z 3))
(mvpsetq (w x) (values 'a 'b) (y z) (values w x))
(list w x y z)))
(test* "onlisp mvpsetq 2" '(10 20 30)
(let ((a 1) (b 2) (c 3))
(mvpsetq a 10 (b c) (values 20 30))
(list a b c)))
(test* "onlisp mvpsetq 3" '(10 20 30)
(let ((a 1))
(receive (b c) (values 2 3)
(mvpsetq a 10 (b c) (values 20 30))
(list a b c))))
(test* "onlisp mvpsetq 4" '(10 20 30)
(receive (a b c) (values 1 2 3)
(mvpsetq (a b c) (values 10 20 30))
(list a b c)))
(test* "onlisp mvpsetq 5" '(10 20 30)
(receive (a b) (values 1 2)
(let ((c 3))
(mvpsetq (a c) (values 10 30) b 20)
(list a b c))))
(test* "onlisp setq 1" '(10 20 30)
(let ((a 1) (b 2) (c 3))
(setq a 10 b 20 c 30)
(list a b c)))
(test* "onlisp setq 2" '(10 20 30)
(let ((a 1) (b 2) (c 3))
(setq obj1 10 obj2 20 obj3 30)
(list obj1 obj2 obj3)))
(test* "onlisp setq 3" '(#f #f #f)
(let ((a 1) (b 2) (c 3))
(setq obj1 #f obj2 #f obj3 #f)
(list obj1 obj2 obj3)))
(test* "onlisp setq 4" '(10 20 30)
(receive (a b c) (values 1 2 3)
(setq a 10 b 20 c 30)
(list a b c)))
(test* "onlisp setq 5" '(10 20 30)
(let ((a 1))
(receive (b c) (values 2 3)
(setq obj1 (* a 10) obj2 (* b 10) obj3 (* c 10))
(list obj1 obj2 obj3))))
(test* "onlisp setq 6" '(10 20 30)
(let ((a 10) (b 20) (c 30))
(setq x a y b z c)
(list x y z)))
(test* "onlisp setq 7" '(foo bar goo)
(let ((x-obj 'foo) (y-obj 'bar) (z-obj 'goo))
(setq foo x-obj bar y-obj goo z-obj)
(list foo bar goo)))
(test* "onlisp mvdo 1" '(6 4 5)
(mvdo ((x 1 (+ 1 x))
((y z) (values 0 0) (values z x)))
((> x 5) (list x y z))
(format #f "~a" (list x y z))))
(test* "onlisp mvdo 2" "(1 0 0)(2 0 1)(3 1 2)(4 2 3)(5 3 4)"
(with-output-to-string
(lambda ()
(mvdo ((x 1 (+ 1 x))
((y z) (values 0 0) (values z x)))
((> x 5) (list x y z))
(write (list x y z))))))
(test* "onlisp _! 1" '(2 4 6)
(let ((x '(1 2 3)))
(_! * (car x) 2)
(_! * (cadr x) 2)
(_! * (caddr x) 2)
x))
(test* "onlisp pull 1" '(1 2 4 5)
(let ((x '(1 2 3 4 5)))
(pull 3 x)
x))
(test* "onlisp pull-if 1" '(1 3 5 7 9)
(let ((x '(0 1 2 3 4 5 6 7 8 9 10)))
(pull-if even? x)
x))
(test* "onlisp popn 1" '(d e f)
(let ((x '(a b c d e f)))
(popn 3 x)
x))
(test* "onlisp rotatef 1" '((4 5 6)(7 8 9)(1 2 3))
(let ((x '(1 2 3)) (y '(4 5 6)) (z '(7 8 9)))
(rotatef x y z)
(list x y z)))
(test* "onlisp rotatef 2" '(3 #(1 2 100 4 5 6 7 8 9) (10 200 300))
(receive (x v i lst)
(values 10 #(1 2 3 4 5 6 7 8 9) 1 '(100 200 300))
(rotatef x (vector-ref v (inc! i)) (car lst))
(list x v lst)))
(test* "onlisp sortf 1" '(5 4 3 2 1)
(receive (a b c d e) (values 3 1 4 5 2)
(sortf > a b c d e)
(list a b c d e)))
(test* "onlisp sortf 2" '("Good,Morning!" "Hello,World!" "Good,Night!" "Fine!" "bye!")
(receive (a b c d e)
(values "bye!" "Good,Night!" "Fine!" "Hello,World!" "Good,Morning!")
(sortf (lambda (s1 s2)
(>= (string-length s1)
(string-length s2)))
a b c d e)
(list a b c d e)))
(test* "onlisp sortf 3" '(100 #(1 2 10 4 5 6 7 8 9) (3 200 300))
(receive (x v i lst)
(values 10 #(1 2 3 4 5 6 7 8 9) 1 '(100 200 300))
(sortf > x (vector-ref v (inc! i)) (car lst))
(list x v lst)))
(test* "onlisp most-of 1" #t
(most-of #f #t #t #t #t #f))
(test* "onlisp nthmost 1" 80
(nthmost 20 (iota 100 1)))
(test* "onlisp nthmost 2" '(nth 20 (sort (list-copy (iota 100 1)) >))
(%macroexpand-1 (nthmost 20 (iota 100 1))))
(test* "onlist nthmost 3" 10
(nthmost 0 (iota 10 1)))
(test* "onlist nthmost 4" 7
(nthmost 3 (iota 10 1)))
;; This test has no mean...
;; only for check refactoring in future.
(test* "onlisp genbez 1" #,(<array> (0 20 0 2)
0 0
0.15000000000000002 0.15000000000000002
0.30000000000000004 0.30000000000000004
0.45000000000000007 0.45000000000000007
0.6000000000000001 0.6000000000000001
0.75 0.75
0.9000000000000001 0.9000000000000001
1.05 1.05
1.2000000000000002 1.2000000000000002
1.35 1.35
1.5 1.5
1.6500000000000001 1.6500000000000001
1.8000000000000003 1.8000000000000003
1.9500000000000002 1.9500000000000002
2.1 2.1
2.25 2.25
2.4000000000000004 2.4000000000000004
2.5500000000000003 2.5500000000000003
2.7 2.7
3 3)
(begin
(genbez 0 0 1 1 2 2 3 3)
(with-module onlisp *pts*)))
(test* "onlisp genbez 1" #,(<array> (0 20 0 2)
0 0
0.12150000000000002 0.264
0.19200000000000003 0.4620000000000001
0.2205 0.6030000000000001
0.21600000000000003 0.6960000000000002
0.1875 0.75
0.1439999999999999 0.774
0.09450000000000003 0.7769999999999999
0.04800000000000004 0.7680000000000002
0.013500000000000068 0.7560000000000002
0.0 0.75
0.01649999999999996 0.7590000000000003
0.07200000000000006 0.7920000000000003
0.1755 0.8580000000000001
0.33600000000000074 0.9660000000000002
0.5625 1.125
0.8640000000000008 1.3440000000000012
1.2495000000000016 1.6320000000000014
1.7280000000000006 1.998000000000001
3 3)
(begin
(genbez 0 0 1 2 -2 -1 3 3)
(with-module onlisp *pts*)))
(test* "onlisp aif 1" #t
(aif #t it #f))
(test* "onlisp aif 2" 15
(aif (+ 1 2 3 4 5) it))
(test* "onlisp aif 3" '(let ((it (+ 1 2 3 4 5)))
(if it (* it it)))
(%macroexpand-1 (aif (+ 1 2 3 4 5) (* it it)))
equal-expr?)
(test* "onlisp awhen 1" (expt (+ 1 2 3 4 5) (+ 1 2 3 4 5))
(awhen (+ 1 2 3 4 5)
(* it it)
(expt it it)))
(test* "onlisp awhen 2" '(aif (+ 1 2 3 4 5)
(begin
(* it it)
(expt it it)))
(%macroexpand-1 (awhen (+ 1 2 3 4 5)
(* it it)
(expt it it)))
equal-expr?)
(test* "onlisp awhile 1" 15
(let ((lst '(1 2 3 4 5 #f 6 7 8 9))
(count 0))
(awhile (pop! lst)
(inc! count it))
count))
(test* "onlisp aand 1" 16
(aand 1 (* 2 it) (* 2 it) (* 2 it) (* 2 it)))
(test* "onlisp acond 1" "OK"
(acond (#f "NG")
(#t "OK")))
(test* "onlisp acond 2" "OK"
(acond ((= 1 2) it)
((equal? "NG" "OK") it)
((car '("OK" "NG")) it)))
(test* "onlisp alambda 1" 3628800
((alambda (x) (if (= x 0) 1 (* x (self (- x 1))))) 10))
(test "onlisp alambda 2" '(1 2 1 2)
(lambda ()
(define (count-instances obj lists)
(map (alambda (list)
(if (not (null? list))
(+ (if (eq? (car list) obj) 1 0)
(self (cdr list)))
0))
lists))
(count-instances 'a '((a b c) (d a r p a) (d a r) (a a)))))
(test "onlisp ablock 1" "ho ho ho "
(lambda ()
(define (princ str)
(format #t str)
(format #f str))
(with-output-to-string
(lambda ()
(ablock north-pole
(princ "ho ")
(princ it)
(princ it)
(north-pole #t)
(princ "he ")
(princ it))))))
(test* "onlisp aif2 1" "Normal"
(aif2 (values #f #t)
"Normal" "Error"))
(test* "onlisp aif2 2" 20
(aif2 (values 10 #f)
(* 2 it) (* 3 it)))
(test* "onlisp aif2 3" #t
(aif2 (values 2 #f)
(number? it) #f))
(test* "onlisp aif2 4" 'yes
(aif2 (values #t 100)
(if it 'yes 'no)
'maybe))
(test* "onlisp aif2 5" 'maybe
(aif2 (values #f #f)
(if it 'yes 'no)
'maybe))
(test* "onlisp awhen2 1" 1024
(awhen2 (values #f 10)
(let ((x 2)
(y 10))
(expt x y))))
(test* "onlisp awhen2 2" 1024
(awhen2 (values 2 #f)
(let1 x 10
(expt it x))))
(test* "onlisp awhile2 1" 3628800
(let ((i 0) (count 1))
(awhile2 (if (< i 10)
(values #t i)
(values #f #f))
(inc! i)
(set! count (* count i)))
count))
(test* "onlisp acond2 1" "OK"
(acond2 ((values #f #f) "NG")
((values 10 #f) "OK")))
(test* "onlisp acond2 2" 3125
(acond2 ((values 5 #f) (expt it it))
((values #t #t) "NG")
(else "ERROR")))
(test* "onlisp fn 1" '(#f #t #f #t #f #t #f #t #f #t)
(map (fn (and integer? odd?)) (iota 10)))
(test* "onlisp fn 2" '(#t #f #t #f #t #f #t)
(map (fn (or integer? symbol? procedure?))
(list list define 'set! set! 10 1.1 -)))
(test* "onlisp fn 3" '(2 2 4 4 6 6 8 8 10 10)
(map (fn (if odd? (lambda (x) (+ 1 x)) identity))
(iota 10 1)))
(test* "onlisp fn 4" '((0 1 2) (1 2 3) (2 3 4))
(map (fn (list (lambda (x) (- x 1))
identity
(lambda (x) (+ x 1))))
'(1 2 3)))
(test* "onlisp fn 5" '(c 2 3-4) ;; at scheme nil is #t
(remove (fn (or (and integer? odd?)
(and pair? cdr)))
'(1 (a b) c (d) 2 3-4 (e f g))))
(test* "onlisp fn 6" '((2.0) (3.0) (0.0) (1.0) (12.0))
(map (fn (compose list (lambda (x) (+ 1 x)) truncate))
'(1.3 2.1 -1.1 0.5 11.3)))
(test* "onlisp fn 7" '(lambda (x) (and (integer? x) (odd? x)))
(%macroexpand (fn (and integer? odd?)))
equal-expr?)
(test* "onlisp fn 8" '(lambda (g)
(list ((lambda (x) (+ x 1)) (truncate g))))
(%macroexpand (fn (compose
list
(lambda (x) (+ x 1)) truncate)))
equal-expr?)
(test* "onlisp fn 9" '(lambda (g)
(list ((lambda (x) (- x 1)) g)
(identity g)
((lambda (x) (+ x 1)) g)))
(%macroexpand (fn (list (lambda (x) (- x 1))
identity
(lambda (x) (+ x 1)))))
equal-expr?)
(test* "onlisp fn 10" '(lambda (g)
(if (odd? g)
((lambda (x) (+ x 1)) g)
(identity g)))
(%macroexpand (fn (if odd? (lambda (x) (+ x 1)) identity)))
equal-expr?)
(test* "onlisp alrec 1" #t
((alrec (and (odd? it) (rec)) #t) '(1 3 5)))
(test* "onlisp alrec 2" #f
((alrec (and (odd? it) (rec)) #t) (iota 10)))
(test* "onlisp alrec 3" (iota 10)
((alrec (cons it (rec))) (iota 10)))
(test* "onlisp alrec 4" (iota 10 1)
((alrec (cons (+ it 1) (rec))) (iota 10)))
(test* "onlisp alrec 5" 10
((alrec (+ 1 (rec)) 0) (iota 10)))
(test* "onlisp alrec 6" 5
((alrec (+ 1 (rec)) 0) '(a b (c d) (e) (f g h))))
(test* "onlisp alrec 7" (iota 10)
((alrec (append (mklist it) (rec))) '((0) 1 2 (3 4) (5 6 7) (8 9))))
(test* "onlisp on-cdrs 1" #t
(let* ((our-copy (lambda (lst)
(on-cdrs (cons it (rec)) '() lst)))
(lst '(1 2 3 4 5 6 7 8 9 10))
(cpy (our-copy lst)))
(and (not (eq? lst cpy))
(equal? lst cpy))))
(test* "onlisp on-cdrs 2" '()
(let ((our-copy (lambda (lst)
(on-cdrs (cons it (rec)) '() lst))))
(our-copy ())))
(test* "onlisp on-cdrs 3" (iota 9 1)
(let* ((our-remove-duplicates (lambda (lst)
(on-cdrs (lset-adjoin = (rec) it) '() lst)))
(lst '(1 2 3 4 5 6 7 8 9 10)))
(our-remove-duplicates '(2 3 1 4 6 1 4 5 9 8 1 2 3 4 5 6 7 8 9)))
(lambda args (apply lset= = args)))
(test* "onlisp on-cdrs 4" '()
(let* ((our-remove-duplicates (lambda (lst)
(on-cdrs (lset-adjoin = (rec) it) '() lst)))
(lst '()))
(our-remove-duplicates '()))
(lambda args (apply lset= = args)))
(test* "onlisp on-cdrs 5" 1
(let* ((our-find-if (lambda (fn lst)
(on-cdrs (if (fn it) it (rec)) #f lst))))
(our-find-if number? '(1 2 3 4 5 6 7 8 9))))
(test* "onlisp on-cdrs 6" #f
(let* ((our-find-if (lambda (fn lst)
(on-cdrs (if (fn it) it (rec)) #f lst))))
(our-find-if number? '())))
(test* "onlisp on-cdrs 7" 1
(let ((our-find-if (lambda (fn lst)
(on-cdrs (if (fn it) it (rec)) #f lst))))
(our-find-if number? '(#t #f '() + inc! define-macro 1))))
(test* "onlisp on-cdrs 8" #f
(let ((our-find-if (lambda (fn lst)
(on-cdrs (if (fn it) it (rec)) #f lst))))
(our-find-if number? (list #t #f '() + inc! define-macro))))
(test* "onlisp on-cdrs 9" #t
(let ((our-some (lambda (fn lst)
(on-cdrs (or (fn it) (rec)) #f lst))))
(our-some number? (list #t #f '() + inc! define-macro 1))))
(test* "onlisp on-cdrs 10" #f
(let ((our-some (lambda (fn lst)
(on-cdrs (or (fn it) (rec)) #f lst))))
(our-some number? (list #t #f '() + inc! define-macro))))
(test* "onlisp on-cdrs 11" #f
(let ((our-some (lambda (fn lst)
(on-cdrs (or (fn it) (rec)) #f lst))))
(our-some number? ())))
(test* "onlisp atrec 1" '(1 2 3)
((atrec (cons (left) (right))) '(1 2 3)))
(test* "onlisp atrec 2" '(() () ())
((atrec (cons (left) (right)) '()) '(1 2 3)))
(test* "onlisp atrec 3" '(1 2 3)
((atrec (cons (left) (right)) it) '(1 2 3)))
(test* "onlisp atrec 3" '(1 (2) (3 4) (5 (6 (7) 8) 9))
((atrec (cons (left) (right)) it) '(1 (2) (3 4) (5 (6 (7) 8) 9))))
(test* "onlisp atrec 4" '((#t #t (#t) (#t #t)))
((atrec (cons (left) (right)) (if (null? it) it #t)) '((1 2 (3) (4 5)))))
(test* "onlisp atrec 5" 5
((atrec (+ (left) (right)) (if (null? it) 0 1)) '(1 2 3 4 5)))
(test* "onlisp atrec 6" 10
((atrec (+ (left) (right)) (if (null? it) 0 1)) '(((0) 1 2) (3) (4 (5 (6 7) (8))) 9)))
(test* "onlisp atrec 7" (iota 10)
((atrec (append (left) (right)) (mklist it)) '(((0) 1 2) (3) (4 (5 6 (7 (8)) 9)))))
(test* "onlisp atrec 8" #t
((atrec (and (left) (right)) (if (null? it) #t (odd? it))) '(1 3 5)))
(test* "onlisp on-trees 1" #t
(let* ((our-copy-tree (lambda (tree)
(on-trees (cons (left) (right)) it tree)))
(lst (cons (iota 10 30) (cons (iota 10 20) (iota 10 1))))
(cpy (our-copy-tree lst)))
(and (not (eq? lst cpy))
(equal? lst cpy))))
(test* "onlisp on-trees 2" 10
(let ((count-leaves (lambda (tree)
(on-trees (+ (left) (right)) (if (null? it) 0 1) tree))))
(count-leaves '(1 2 3 4 5 6 7 8 9 10))))
(test* "onlisp on-trees 3" 10
(let ((count-leaves (lambda (tree)
(on-trees (+ (left) (right)) (if (null? it) 0 1) tree))))
(count-leaves '((1 2 3 4) 5 6 (7 (8)) 9 10))))
(test* "onlisp on-trees 4" (iota 10 1)
(let* ((flatten (lambda (tree)
(on-trees (append! (left) (right)) (mklist it) tree))))
(flatten '((1 2) (3) 4 (5 (6 7 (8 (9)) 10))))))
(test* "onlisp on-trees 5" 1
(let ((rfind-if (lambda (fn tree)
(on-trees (or (left) (right))
(and (fn it) it)
tree))))
(rfind-if (fif number? odd?) '(0 1 2 3))))
(test* "onlisp on-trees 6" 7
(let ((rfind-if (lambda (fn tree)
(on-trees (or (left) (right))
(and (fn it) it)
tree))))
(rfind-if (fif number? odd?) '((0) (2 4) (6 (7 8) 1)))))
(test* "onlisp delay 1" #t
(let1 promise (delay 1)
(delay? promise)))
(test* "onlisp delay 2" #t
(delay? (delay 1)))
(test* "onlisp force 1" 12
(let1 promise (delay 12)
(force promise)))
(test* "onlisp delay? 1" #t
(let1 promise (delay (iota 10))
(delay? promise)))
(test* "onlisp delay? 2" #f
(let1 promise (delay (iota 10))
(force promise)
(delay? promise)))
(test* "onlisp delay/force 1" "foo(1 1)"
(with-output-to-string
(lambda ()
(define x (delay (begin
(display 'foo)
1)))
(display (list (force x) (force x))))))
(test* "onlisp abbrev 1" '(define-macro (s . args)
`(,'loooooooooong ,@args))
(%macroexpand (abbrev s loooooooooong)))
(test* "onlisp abbrevs 1" '(begin
(abbrev s1 long)
(abbrev s2 loong)
(abbrev s3 looong)
(abbrev s4 loooong)
(abbrev s5 looooong))
(%macroexpand (abbrevs s1 long
s2 loong
s3 looong
s4 loooong
s5 looooong)))
(test* "onlisp propmacro 1" '(define-macro (color obj)
`(get ,obj ','color))
(%macroexpand (propmacro color)))
(test* "onlisp propmacros 1" '(begin
(propmacro color)
(propmacro shape)
(propmacro size)
(propmacro weight)
(propmacro hardness))
(%macroexpand (propmacros color shape size weight hardness)))
(propmacros name age bwh)
(test* "onlisp propmacros 2" '(花子 20 (86 58 88))
(let ((lady '((name . 花子)
(age . 20)
(bwh 86 58 88))))
(list (name lady) (age lady) (bwh lady))))
(test* "onlist a+ 1" '(let* ((g1 menu-price) (it g1))
(let* ((g2 (+ it 0.05)) (it g2))
(let* ((g3 (* it 3)) (it g3))
(+ g1 g2 g3))))
(%macroexpand (a+ menu-price (+ it .05) (* it 3)))
equal-expr?)
(test* "onlisp alist 1" '(let* ((g1 1) (it g1))
(let* ((g2 (+ 2 it)) (it g2))
(let* ((g3 (+ 2 it)) (it g3))
(list g1 g2 g3))))
(%macroexpand (alist 1 (+ 2 it) (+ 2 it)))
equal-expr?)
(test* "onlisp pop-symbol 1" #t
(symbol? (pop-symbol 'abc)))
(test* "onlisp defanaph 1" '(define-macro (a+ . args)
(anaphex args (list '+)))
(%macroexpand (defanaph a+)))
(test* "onlisp defanaph 2" '(define-macro (alist . args)
(anaphex args (list 'list)))
(%macroexpand (defanaph alist)))
(test* "onlisp defanaph 3" '(define-macro (foo . args)
(anaphex args (list '-)))
(%macroexpand (defanaph foo -)))
(test* "onlisp defanaph 4" '(define-macro (bar . args)
(anaphex args
(list '(lambda args (apply * args)))))
(%macroexpand (defanaph bar (lambda args (apply * args)))))
(defanaph aplus +)
(defanaph alists list)
(test* "onlisp defanaph 5" (+ 2 (+ 2 3) (* (+ 2 3) (+ 2 3)) (expt 2 (* (+ 2 3) (+ 2 3))))
(aplus 2 (+ it 3) (* it it) (expt 2 it)))
(test* "onlisp defanaph 6" '("foo" "foofoo" "foofoofoofoo")
(alists "foo" (string-append it it) #`",|it|,|it|"))
(test* "onlisp def-anaph 1" '(define-macro (aname . args)
(anaphex1 args '(name)))
(%macroexpand (def-anaph aname)))
(test* "onlisp def-anaph 2" '(define-macro (aname . args)
(anaphex1 args '(call)))
(%macroexpand (def-anaph aname :call call)))
(test* "onlisp def-anaph 3" '(define-macro (aname . args)
(anaphex1 args '(call)))
(%macroexpand (def-anaph aname :call call :rule :all)))
(test* "onlisp def-anaph 4" ' (define-macro (aname . args)
(anaphex2 'call args))
(%macroexpand (def-anaph aname :call call :rule :first)))
(test* "onlisp def-anaph 5" ' (define-macro (aname . args)
(anaphex3 'call args))
(%macroexpand (def-anaph aname :call call :rule :place)))
(def-anaph a*)
(def-anaph a-sum :call +)
(def-anaph a-sum2 :call + :rule :all)
(def-anaph a-if :call if :rule :first)
(def-anaph a-inc! :call inc! :rule :place)
(test* "onlisp def-anaph 6" (* 1 (+ 1 1) (* (+ 1 1) (+ 1 1)))
(a* 1 (+ it it) (* it it)))
(test* "onlisp def-anaph 7" 263
(a-sum 1 (+ it it) (* it it) (expt it it)))
(test* "onlisp def-anaph 8" 263
(a-sum2 1 (+ it it) (* it it) (expt it it)))
(test* "onlisp def-anaph 9" #t
(a-if #t it #f))
(test* "onlisp def-anaph 10" 15
(a-if (+ 1 2 3 4 5) it))
(test* "onlisp def-anaph 11" '(let ((it (+ 1 2 3 4 5)))
(if it (* it it)))
(%macroexpand-1 (a-if (+ 1 2 3 4 5) (* it it))))
(test* "onlisp def-anaph 12" (* (+ 1 2 3 4 5) (+ 1 2 3 4 5))
(a-if (+ 1 2 3 4 5) (* it it)))
(test* "onlisp def-anaph 13" (cons (+ 1 1 1) (+ 2 (* 2 2)))
(let1 p (cons 1 2)
(a-inc! (car p) (+ it it))
(a-inc! (cdr p) (* it it))
p))
(test* "onlisp destruc 1" '((a (ref seq 0)) (b (ref seq 1)) (c (ref seq 2)))
(destruc '(a b c) 'seq))
(test* "onlisp destruc 2" '((a (ref seq 0)) (b (ref seq 1)) (c (ref seq 2)))
(destruc '(a b c) 'seq atom?))
(test* "onlisp destruc 3" '((a (ref seq 0)) (b (ref seq 1)) (c (ref seq 2)))
(destruc '(a b c) 'seq atom? 0))
(test* "onlisp dbind-ex 1" '(let ((a (ref seq 0))
(b (ref seq 1))
(c (ref seq 2)))
(begin body))
(dbind-ex (destruc '(a b c) 'seq) '(body)))
(test* "onlisp dbind-ex 2" `(let ((a (ref seq 0))
(g1 (ref seq 1))
(d (,subseq seq 2)))
(let ((b (ref g1 0))
(c (,subseq g1 1)))
(begin body)))
(dbind-ex (destruc '(a (b . c) :rest d) 'seq) '(body))
equal-expr?)
(test* "onlisp dbind 1" '(let ((g1 '(1 2 3)))
(let ((a (ref g1 0))
(b (ref g1 1))
(c (ref g1 2)))
(begin (list a b c))))
(%macroexpand-1 (dbind (a b c) '(1 2 3)
(list a b c)))
equal-expr?)
(test* "onlisp dbind 2" '(1 2 3)
(dbind (a b c) '(1 2 3)
(list a b c)))
(test* "onlisp dbind 3" '(1 2 3 4 5)
(dbind (a (d e) b c) '(1 (4 5) 2 3)
(list a b c d e)))
(test* "onlisp dbind 4" '(1 2 3 4 (5))
(dbind (a (d . e) b c) '(1 (4 5) 2 3)
(list a b c d e)))
(test* "onlisp dbind 5" '(1 2 3 4 5)
(dbind (a (d . e) b c) '(1 (4 5) 2 3)
(apply list a b c d e)))
(test* "onlisp dbind 6" '(let ((g1 '(1 (4 5) 2 3)))
(let ((a (ref g1 0))
(g2 (ref g1 1))
(b (ref g1 2))
(c (ref g1 3)))
(let ((d (ref g2 0))
(e (ref g2 1)))
(begin (list a b c)
(list d e)))))
(%macroexpand-1 (dbind (a (d e) b c) '(1 (4 5) 2 3)
(list a b c)
(list d e)))
equal-expr?)
(test* "onlisp dbind 7" '(1 2 3 4 5)
(dbind (a (d e) b c) #(1 (4 5) 2 3)
(list a b c d e)))
(test* "onlisp dbind 8" '(1 2 3 4 5)
(dbind (a (b c) d e) '(1 #(2 3) 4 5)
(list a b c d e)))
(test* "onlisp dbind 9" '(1 #\f "ribble" (2 3 4))
(dbind (a (b . c) :rest d) '(1 "fribble" 2 3 4)
(list a b c d)))
(test* "onlisp dbind 10" '(a #\f "ribble" 1 2 3)
(dbind (a (b . c) (d e f)) '(a "fribble" #(1 2 3))
(list a b c d e f)))
(test* "onlisp with-matrix 1" '(0 1 2 10 11 12 20 21 22)
(let ((ar (make-array (shape 0 3 0 3))))
(for (r 0 2)
(for (c 0 2)
(set! (array-ref ar r c) (+ (* r 10) c))))
(with-matrix ((a b c)
(d e f)
(g h i))
ar
(list a b c d e f g h i))))
(test* "onlisp with-array 1" '(0 11 22)
(let ((ar (make-array (shape 0 3 0 3))))
(for (r 0 2)
(for (c 0 2)
(set! (array-ref ar r c) (+ (* r 10) c))))
(with-array ((a 0 0) (d 1 1) (i 2 2)) ar
(list a d i))))
(test* "receive* 1" '(1)
(receive* args 1 args))
(test* "receive* 2" '(1 2)
(receive* args (values 1 2) args))
(test* "receive* 3" '(1 #f)
(receive* (a b) 1 (list a b)))
(test* "receive* 4" '(1 #f)
(receive* (a b) (values 1) (list a b)))
(test* "receive* 5" '(1 2)
(receive* (a b) (values 1 2) (list a b)))
(test* "receive* 6" '(1 2)
(receive* (a b) (values 1 2 3) (list a b)))
(test* "match function 1" '(() #t)
(receive args
(match-fn 'x 'x)
args))
(test* "match function 2" '(() #t)
(receive args
(match-fn 'x '_)
args))
(test* "match function 3" '(() #t)
(receive args
(match-fn '_ 'y)
args))
(test* "match function 4" '(#f #f)
(receive args
(match-fn 'x 'y)
args))
(test* "match function 5" '(((?y . b) (?x . a)) #t)
(receive args
(match-fn '(p a b c a) '(p ?x ?y c ?x))
args))
(test* "match function 6" '(#f #f)
(receive args
(match-fn '(a b c) '(a a a))
args))
(test* "match function 7" '(((?y . c) (?x . ?y)) #t)
(receive args
(match-fn '(p ?x b ?y a) '(p ?y b c a))
args))
(test* "if-match-ls 1" '(hi ho)
(receive args
(let ((abab (lambda (seq)
(if-match-ls (?x ?y ?x ?y) seq
(values ?x ?y)
'()))))
(abab '(hi ho hi ho)))
args))
(test* "if-match 1" '(hi ho)
(receive args
(let ((abab (lambda (seq)
(if-match (?x ?y ?x ?y) seq
(values ?x ?y)
'()))))
(abab '(hi ho hi ho)))
args))
(test* "if-match 2" '(#\a #\b)
(receive args
(let ((abab (lambda (seq)
(if-match (?x ?y ?x ?y) seq
(values ?x ?y)
'()))))
(abab "abab"))
args))
(test* "if-match 3" '((a b) #(2 3))
(receive args
(if-match (?x (1 . ?y) . ?x) '((a b) #(1 2 3) a b)
(values ?x ?y))
args))
(test* "if-match 4" '()
(if-match (?x ?y ?x) '(1 2 3)
(values ?x ?y) '()))
(test* "if-match 5" "else"
(if-match (?x ?y ?x) '(1 2 3)
(values ?x ?y) "else"))
(test* "if-match 6" 1
(let ((n 3))
(if-match (?x n 'n '(a b)) '(1 3 n (a b))
?x)))
(test* "if-match 7" '((a b) #(2 3))
(receive args
(if-match (?x (1 . ?y) . ?x) '((a b) #(1 2 3) a b)
(values ?x ?y))
args))
(test-end)
;; Local variables:
;; mode: scheme
;; end:
(define-module simple-draw
(use srfi-1)
(export <point> <line>
make-point make-line get-min-point get-max-point
move-by! vertical-mirror! horizontal-mirror!
bounds draw draw-objects redraw
)
)
(select-module simple-draw)
;;==============================================
;; class define
;;
(define-class <point> ()
((x :init-value 0
:init-keyword :x
:accessor x-of)
(y :init-value 0
:init-keyword :y
:accessor y-of)))
(define-class <line> ()
((start :init-value (make <point>)
:init-keyword :start
:accessor start-of)
(end :init-value (make <point>)
:init-keyword :end
:accessor end-of)))
;;==============================================
;; define methods
;;
(define-method make-point (x y)
(make <point> :x x :y y))
(define-method make-line (x0 y0 x1 y1)
(make <line>
:start (make-point x0 y0)
:end (make-point x1 y1)))
(define-method draw ((point <point>))
(format #t #`"draw: POINT(,(x-of point),,,(y-of point))~%"))
(define-method draw ((line <line>))
(let ((s (start-of line))
(e (end-of line)))
(format #t #`"draw: LINE(,(x-of s),,,(y-of s))->(,(x-of e),,,(y-of e))~%")))
(define-method get-min-point ((point <point>)) point)
(define-method get-max-point ((point <point>)) point)
(define-method get-min-point ((line <line>))
(let ((s (start-of line))
(e (end-of line)))
(make <point>
:x (min (x-of s) (x-of e)) :y (min (y-of s) (y-of e)))))
(define-method get-max-point ((line <line>))
(let ((s (start-of line))
(e (end-of line)))
(make <point>
:x (max (x-of s) (x-of e)) :y (max (y-of s) (y-of e)))))
(define-method move-by! ((point <point>) dx dy)
(set! (x-of point) (+ (x-of point) dx))
(set! (y-of point) (+ (y-of point) dy))
point)
(define-method move-by! ((line <line>) dx dy)
(set! (x-of (start-of line)) (+ (x-of (start-of line)) dx))
(set! (y-of (start-of line)) (+ (y-of (start-of line)) dy))
(set! (x-of (end-of line)) (+ (x-of (end-of line)) dx))
(set! (y-of (end-of line)) (+ (y-of (end-of line)) dy))
line)
(define-method write-object ((point <point>) port)
(format port #`"#pt[,(x-of point),,,(y-of point)]"))
(define-method write-object ((line <line>) port)
(format port #`"#ln[,(start-of line)-,(end-of line)]"))
(define-method vertical-mirror! ((point <point>)) point)
(define-method horizontal-mirror! ((point <point>)) point)
(define-method vertical-mirror! ((line <line>))
(let ((sx (x-of (start-of line)))
(ex (x-of (end-of line))))
(set! (x-of (start-of line)) ex)
(set! (x-of (end-of line)) sx)
line))
(define-method horizontal-mirror! ((line <line>))
(let ((sy (y-of (start-of line)))
(ey (y-of (end-of line))))
(set! (y-of (start-of line)) ey)
(set! (y-of (end-of line)) sy)
line))
;;==============================================
;; define draw library
;;
(define (draw-objects objs)
(for-each draw objs))
(define (bounds objs)
(letrec ((foldl (lambda (fn lst)
(if (null? lst)
lst
(fold fn (car lst) (cdr lst))))))
(let ((min-points (map get-min-point objs))
(max-points (map get-max-point objs)))
(values (apply min (map x-of min-points))
(apply min (map y-of min-points))
(apply max (map x-of max-points))
(apply max (map y-of max-points))))))
(define (redraw xmin ymin xmax ymax)
(format #t
#`"We redraw for Square from (,xmin,,,ymin) to (,xmax,,,ymax)~%"))
(provide "simple-draw")
現在無し。