2009年7月29日水曜日

マクロを書く練習

LET OVER LAMBDA 邦訳版を読んだため,マクロをうまく書けるようになりたい気持ちが沸いてきた.
ということで,練習がてらに書いてみる.

;;;引数の個数によって動作を変えるlambda
(defmacro olambda (&body body)
(let ((args (gensym "olambda-args")))
`(lambda (&rest ,args)
(case (length ,args)
,@(mapcar
#'(lambda (clause)
`(,(if (listp (car clause))
(length (car clause))
t)
(destructuring-bind ,(car clause)
,args
,@(cdr clause))))
body)))))

LOLに載っていたdlambdaのパクリっぽい.
dlambdaとの違いはキーワード引数ではなくて引数の数で動作を変えること.
lambdaに一文字足した名前にしようと思い,overloadのoを選んでみた.
以下,動作結果.

;;;引数すべての平均値を求める
>(defparameter avg
(olambda
(() 0) ;引数がなければ0を返す
((x) x) ;引数が1つならばそのまま返す
;;2つ以上引数があれば計算して返す
(args (/ (apply #'+ args) (length args)))))

>(funcall avg)
0

>(funcall avg 5)
5

>(funcall avg 1 2 3 4 5)
3

>(macroexpand-1
'(olambda
(() 0)
((x) x)
(args (/ (apply #'+ args) (length args)))))
(LAMBDA (&REST #:|olambda-args1425|)
(CASE (LENGTH #:|olambda-args1425|)
(0 (DESTRUCTURING-BIND () #:|olambda-args1425| 0))
(1 (DESTRUCTURING-BIND (X) #:|olambda-args1425| X))
(T
(DESTRUCTURING-BIND ARGS
#:|olambda-args1425|
(/ (APPLY #'+ ARGS) (LENGTH ARGS))))))

一応考えているとおりに動いてそうだ.

2009年7月24日金曜日

波うさぎ

本日の酒はこちら.
  • 冷酒仕立て 本醸造 波うさぎ(長陵醸造元 高橋酒造株式会社/新潟)
五百万石使用,日本酒度+3,酸度1.2とのこと.
ラベルに「白魚が 冷酒グラスの 紅を拭き」とある.
白魚は春の季語らしいが,目の前にあるので夏場だろうと気にせずにぐいっと.

2009年7月16日木曜日

リーダマクロでドット区切りなメソッド呼び出し風な何か

酔った勢いでリーダマクロを書いた.
(foo bar piyo)をbar.foo(piyo)と書けるようにしてみた.
次の朝にはコードを理解できない可能性が高い.

(defun dot-reader (stream ch1 ch2)
(declare (ignore ch1 ch2))
(cons
'progn
(merge-method-invokation-sexp
(convert-to-method-invokation
(mapcar
#'convert-to-dot-exp
(read-delimited-list #\] stream))))))


(defun convert-to-dot-exp (sexp)
(cond
((listp sexp)
(mapcar #'convert-to-dot-exp sexp))
((symbolp sexp)
(convert-symbol-to-dot-exp sexp))
(t sexp)))

(defun merge-method-invokation-sexp (sexp &optional prev)
(if (null sexp)
;;終端
(if prev (list prev) nil)
(let ((fst (car sexp)))
(if (listp fst)
(case (car fst)
(:method-invoke
(append
(if prev (list prev) nil)
(merge-method-invokation-sexp
(cdr sexp)
`(,(third fst)
,(second fst)
,@(nthcdr 3 fst)))))
(:dot
(merge-method-invokation-sexp
(cdr sexp)
`(,(second fst)
,prev
,@(nthcdr 2 fst)) ))
(t
(append
(if prev (list prev) nil)
(merge-method-invokation-sexp
(cdr sexp)
fst))))
(append
(if prev (list prev) nil)
(merge-method-invokation-sexp
(cdr sexp)
fst))))))

(defun convert-to-method-invokation (sexp)
(if (not (listp sexp)) sexp
(loop
:for rest = sexp then (if (and (listp o)
(or (eq (car o) :dot)
(eq (car o) :method-invoke)))
(cddr rest)
(cdr rest))
:for o = (car rest)
:while rest
:collect
(if (and (listp o)
(or (eq (car o) :dot)
(eq (car o) :method-invoke)))
(append o (second rest))
o))))

(defun convert-symbol-to-dot-exp (sym)
(let ((str (symbol-name sym)))
(let ((pos (position #\. str)))
(if (not pos)
sym
(if (= pos 0)
(list :dot
(convert-symbol-to-dot-exp
(intern (subseq str 1))))
(list
:method-invoke
(read-from-string (subseq str 0 pos))
(convert-symbol-to-dot-exp
(intern (subseq str (1+ pos))))))))))

(set-macro-character #\] (get-macro-character #\)))
(set-dispatch-macro-character #\# #\[ 'dot-reader)

なんとなく動くひどいコード.
酔ってなくてもこのくらいしか書けないレベルですが.
目が覚めて気になったら書きなおそう.

以下実行結果.

>#[(loop :for i from 0 to 10 :collect i).elt(1)]
1
>#[(defparameter a #\0) a.char-code().+(9).code-char()]
#\9

2009年7月13日月曜日

黒龍

今日は刺身をつまみに日本酒を飲んだ.
  • 黒龍 大吟醸 龍(黒龍酒造株式会社/福井)
飲みやすいので調子に乗って飲みすぎそうだ.次の日が怖い.

2009年7月9日木曜日

closure-xml

Common LispのXML,HTMLパーサライブラリに,Closure XML Parserとその仲間たち(stp,chtml等)がある.
asdf-installでインストールできるので楽ちん.
htmlをパースするならこのようにしてパースできるようだ.

;;リストにして返す
(chtml:parse #p"./hoge.html" (chtml:make-lhtml-builder))

;;DOMっぽいもの(CXML-STP)に利用できるオブジェクトを返す
(chtml:parse #p"./hoge.html" (stp:make-builder))

ドキュメントがしっかり書かれているようなので,英語で挫けなければ便利に使えそう.

2009年7月2日木曜日

Ironclad

目に付いたCommonLispのライブラリを挙げてみる.
1回目のネタは最近出会った暗号ライブラリのIronclad.CLikiからホームページに飛べるし,ASDF-INSTALLでいれられる.
ホームページのドメインがmethod-combination.netってのがまた括弧良い.
様々な暗号化やダイジェスト関数(ハッシュ関数)を扱うことのできるライブラリで,暗号化はmake-cipherとencrypt,decryptを使い,ダイジェスト関数には'High-level convenience function'としてdigest-sequenceなどの関数があるので,単純にハッシュ値を求めたいときはこいつを使えばよさそう.