2008/07/31

[Common Lisp] 素数

(loop for l = (loop for i from 2 to 100000 collect i)
then (delete-if {zerop (mod _ x)} (cdr l))
for x = (car l)
while x
collect x)

『数学ガール/フェルマーの最終定理』の記念に

NLISP - A Numerical Common Lisp with Array Syntaxと思ったが、よく分からない。

ま、とりあえずなんか描けたからよしとしよう。

;; cd /tmp
;; svn co https://nlisp.svn.sourceforge.net/svnroot/nlisp/trunk nlisp

(pushnew "/tmp/nlisp/" asdf:*central-registry*)

(require :nlisp)

(use-package :nlisp)

(let ((x (.rseq 0 100 50)))
(plot (.sin x) (.cos x)))

2008/07/29

もうやってられない

そういうときもあるのさ。

2008/07/26

[本] 今月は素敵な月

『実践 Common Lisp』 が発売になった。素晴しい。『Smalltalkで学ぶオブジェクト指向プログラミングの本質』 も発売になった。もうすこしすると 『数学ガール/フェルマーの最終定理』 も発売になる。

今月は素敵な月。

[Common Lisp] 文字列リテラルを作る

こんなふうに書きたくて(CL-INTERPOLのまねごと)

CL-USER> (let ((lang "Common Lisp"))
#"""母国語は "#,lang," です。""")
"母国語は \"Common Lisp\" です。"
CL-USER> (cl-ppcre:scan-to-strings #"""a\d+a""" "axaa123a")
"a123a"
#()
CL-USER> #"(+ 1 2) => #,(+ 1 2)"
"(+ 1 2) => 3"
CL-USER> (read-from-string "#\"(+ 1 2) => #,(+ 1 2)\"")
(FORMAT NIL "(+ 1 2) => ~a" (+ 1 2))
23

こんなふうに作ってみた。

(defun |#"-reader| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(|#"-parser|
(if (equal #\" (peek-char nil stream t nil t))
(progn
(read-char stream)
(if (equal #\" (peek-char nil stream nil nil t))
(|#"""-reader"""| stream)
""))
(|#"-reader"| stream))))

(defun |#"-reader"| (stream)
(funcall (get-macro-character #\") stream #\"))

(defun |#"""-reader"""| (stream)
#1=(read-char stream t nil t)
(with-output-to-string (*standard-output*)
(loop for c1 = #1# then c2
for c2 = #1# then c3
for c3 = #1# then #1#
until (char= #\" c1 c2 c3)
do (write-char c1))))

(defun |#"-parser| (s)
(macrolet ((peek-equal (c)
`(equal ,c (peek-char nil in nil nil))))
(let* ((args nil)
(format
(with-output-to-string (out)
(with-input-from-string (in s)
(loop for c = #1=(read-char in nil nil)
while c
if (and (equal #\# c) (peek-equal #\,))
do (progn
#1#
(write-string "~a" out)
(push (read-preserving-whitespace in) args)
(when (peek-equal #\,)
#1#))
else
do (write-char c out))))))
`(format nil ,format ,@(reveres args)))))

(set-dispatch-macro-character
#\# #\" '|#"-reader|)

またあとで |#"-parser| をもっといじる。

(char= #\a nil) はエラーになるのね。(equal #\, #\c1 #\c2 #\c3) と書けるけど、(equal #\, #\c1 #\c2 #\c3) とは書けないのね。

""" は Python から。

2008/07/25

[Common Lisp] Wassar のコード片

(defun map-fringe (function tree)
(with-ca/dr tree
(cond ((endp tree)
nil)
((atom car)
(cons (funcall function car)
#1=(map-fringe function cdr)))
(t
(cons (map-fringe function car)
#1#)))))

(defun maybe-anaphora-symbol (sym)
(and (symbolp sym)
(< 1 (length (symbol-name sym)))
(char= (char (symbol-name sym) 0) #\@)
(intern (subseq (symbol-name sym) 1))))

(defmacro with-status (status &body body)
(let* (syms
(form (map-fringe (lambda (x)
(aif (maybe-anaphora-symbol x)
(progn (pushnew it syms)
it)
x))
body)))
`(json:json-bind ,syms ,status
,@form)))

(mapc {with-status _
(format t "~&~a(~a): ~a" @user_login_id @user.screen_name @text)}
(json:decode-json-from-string
(http-request "http://api.wassr.jp/statuses/friends_timeline.json"
:basic-authorization *basic-authorization*)))

2008/07/13

[Forth] コンパイル時にスタックをいじると

"LET OVER LAMBDA" のサンプルで出てきた Forth のコードの話。

処理系は gforth で。

普通に 5 から 1 までを表示するコード。ちゃんと begin 〜 again の中に if 〜 then がはいっている。

: countdown
begin
dup 1 < if drop exit [ .s ] then
dup .
1-
again ;

5 countdown

これを、コンパイル中にスタックをいじってみるたりすると、begin 〜 if 〜 again 〜 then なんて順番で書けたりする。普通の言語ならコンパイルエラーだが、これはちゃんと動作する。

: countdown2
begin
dup 1 >= if dup . 1-
[ rot drop 2swap 0 -rot ]
again
then
drop ;

5 countdown2

次の部分で again のジャンプ先と if で偽だった場合のジャンプ先を入れ替えている。LOL のサンプルでは [ swap ] だったけど gforth では begin も if ともに 2 つの値をスタックに積むようで、さらにダミーの 0 が間に入っていたいりするので強引にいれかえるコードになってしまった。ん? 3つの値をつむのか。

[ rot drop 2swap 0 -rot ]

Forth ではこんなふうに文法さえ無視することができる。もちろん Forth だから文法なんかじゃなくて、begin も again も if も then も単なる word(関数)でしかないのだけどね。

こんなことができたりするから Forth はたまらない。

あれ? コードに色が付かない。。。

2008/07/12

娘はお泊り保育

今日は娘はお泊り保育でいない。いつも夜更かしのあのこはちゃんと眠れているかな。

[Common Lisp] 第7回 慢性的CL勉強会@Lingr 8時だョ!全員集合 のお題 The Common Lisp Cookbook - The Loop Macro を SERIES で

第7回 慢性的CL勉強会@Lingr 8時だョ!全員集合 のお題 The Common Lisp Cookbook - The Loop Macro を SERIES で。

サンプルコードによるSERIES入門 (番外編) は素晴しい。SERIES もっとはやるといいな。

;;;; The Common Lisp Cookbook - The Loop Macro
;;;; (http://cl-cookbook.sourceforge.net/loop.html)
;;;; を SERIES でやってみる。
;;;;
;;;; マニュアルはソースにくっついてくる s-doc.txt

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :series))

(in-package :series)

;; #Z, #M を使えるようにする。
(eval-when (:compile-toplevel :load-toplevel :execute)
(install))

;;; a〜e を print する。
(#Mprint #z(a b c d e))
;; #Z(A B C D E)
;;; #M... は (map-fn t #'... と同じ。
(map-fn t #'print #z(a b c d e))
;; #Z(A B C D E)


;;; 2つのシリーズを1つに
(#Mlist #z(a b c d e) #z(1 2 3 4 5))
;; #Z((A 1) (B 2) (C 3) (D 4) (E 5))


;;; 1〜5 のシリーズをつくって、2倍する。
(mapping ((i (scan-range :from 1 :upto 5)))
(* 2 i))
;; #Z(2 4 6 8 10)


;;; 条件は普通に書ける。iterate は副作用を目的とする場合に。
(iterate ((x #z(a b c d e))
(y (scan-range :from 1)))
(when (> y 1)
(format t ", "))
(format t "~A" x))
;; A, B, C, D, E
;; NIL


;;; (scan-range :from 1) は無限だけど #z(a b c d e) の方で停止する。
(iterate ((x #z(a b c d e))
(y (scan-range :from 1)))
(if (> y 1)
(format t ", ~A" x)
(format t "~A" x)))
;; A, B, C, D, E
;; NIL


;;; until で停止させる。
(let* ((s #z(a b c d e 1 2 3 4))
(b (#Mnumberp s)))
(mapping ((x (until b s)))
(list x 'foo)))
;; #Z((A FOO) (B FOO) (C FOO) (D FOO) (E FOO))


;;; これも until で停止
(let* ((x (scan-range :from 1))
(y (#M(lambda (x) (* x 10)) x))
(b (#M(lambda (y) (>= y 100)) y)))
(mapping ((x x) (y (until b y)))
(print (* x 5))
y))
;; #Z(10 20 30 40 50 60 70 80 90)


;;; 二重ループ
(#M(lambda (x) (scan-range :from 1 :upto x))
(scan-range :from 1 :upto 10))
;; #Z(#Z(1) #Z(1 2) #Z(1 2 3) #Z(1 2 3 4) #Z(1 2 3 4 5) #Z(1 2 3 4 5 6) #Z(1 2 3 4 5 6 7) #Z(1 2 3 4 5 6 7 8) #Z(1 2 3 4 5 6 7 8 9) #Z(1 2 3 4 5 6 7 8 9 10))


;;; destructuring-bind したいのだけど。。。
;; なんかいい手はないかな?
(mapping ((x #z((x 1) (y 2) (z 3))))
(list (cadr x) (car x)))
;; #Z((1 X) (2 Y) (3 Z))


;;; 苦しい。previous がないと #\a がかえっちゃう。
(let ((s (scan "alpha45")))
(collect-last
(until
(previous (#M(lambda (ch)
(find ch "0123456789" :test #'eql))
s) nil)
s)))
;; #\4


;;; 1つでも真があれば
(collect-or (#Mnumberp #z(foo 2)))
;; T


;;; 1つも真でなければ
;; not をかますしかないのかな?
(collect-and (#Mnot (#Mnumberp #z(foo 2))))
;; NIL


;;; 全て真なら
(collect-and (#Mnumberp #z(foo 2)))
;; NIL

[Common Lisp] L-99 の P01 のために SERIES を拡張してみた

L-99 の P01 のために SERIES を拡張してみた。

g000001 さんが楽しんでらっしゃる L-99 を SERIES でやってみようかな、と思ったらさっそく一問目からつまずいた。

最後の要素をとってくる collect-last はあっても、最後のセルをとってくる関数がみあたらない。しかたないので collect-last-cons を作ってみた。でも、よくわかっていない。

fragl(どういう意味だろう?)手強い。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :series))

(in-package :series)

(eval-when (:compile-toplevel :load-toplevel :execute)
(install))

(defS collect-last-cons (items)
"P01"
(fragl ((items t)) ; args
((cons)) ; rets
((cons list nil)) ; aux
() ; alt
() ; prolog
() ; body
((setq cons (list items))) ; epilog
() ; wraprs
nil) ; ?
:trigger t)

(assert (equal '(d)
(collect-last-cons #z(a b c d))))

;; 展開するとこうなる。なので新しい cons を返してしまっている。
(pprint (macroexpand-1 '(collect-last-cons #z(a b c d))))
;; (COMMON-LISP:LET* ((#:LISTPTR-842 '(A B C D)) #:ELEMENTS-843)
;; (DECLARE (TYPE LIST #:LISTPTR-842))
;; (TAGBODY
;; #:LL-844
;; (IF (ENDP #:LISTPTR-842) (GO END))
;; (SETQ #:ELEMENTS-843 (CAR #:LISTPTR-842))
;; (SETQ #:LISTPTR-842 (CDR #:LISTPTR-842))
;; (GO #:LL-844)
;; END)
;; (LIST #:ELEMENTS-843))

[Common Lisp] list 関数の定義

なるほど。list が呼び出されるとき、すでに list がすべき仕事は終っているのか。

SBCL のソース

(defun list (&rest args)
#!+sb-doc
"Return constructs and returns a list of its arguments."
args)

2008/07/08

[Common Lisp] LET OVER LAMBDA でステートマシン

LISPUSER さんとこの Common Lisp で簡単ステートマシンマクロ で題材になっているステートマシンを LET OVER LAMBDA でやってみようかと思ったら、ちょっと違った方向にいってしまった。

plambda は自身の手続を this に持っていて、それを外部から書きかえて状態が遷移できる、という予定だったけど、何故か case* マクロを書いておわってしまった。

this の書きかえはまたそのうちに。

(defpan print-status (tray player)
(format t "~&tray => ~a~%player => ~a" tray player))

(let* ((tray :close)
(player :stop)
(cd-player (plambda (action) (tray player)
(format t "~&Action: ~a" action)
(case* (action tray player)
((:open :close :play)
(print ">>> STOP")
(setf player :stop)
(print ">>> OPEN")
(setf tray :open))
((:open :close :stop)
(print ">>> OPEN")
(setf tray :open))
((:close :open _)
(print ">>> CLOSE")
(setf tray :close))
((:play :close :stop)
(print ">>> PLAY")
(setf player :play))
((:play :open _)
(print ">>> CLOSE")
(setf tray :close)
(print ">>> PLAY")
(setf player :play))
((:stop _ _)
(print ">>> STOP")
(setf player :stop))
(t
(warn "Ignore action: ~a for tray: ~a, player: ~a."
action tray player)
:ignore)))))
(funcall cd-player :play)
(funcall cd-player :open)
(funcall cd-player :open)
(funcall cd-player :play)
(funcall cd-player :stop)
(funcall cd-player :open)
(funcall cd-player :close)
(print-status cd-player))

(defmacro case* (keyform &body cases)
`(cond ,@(mapcar #`(,(if (consp (car a1))
`(and
,@(loop for k in keyform
for v in (car a1)
unless (eq v '_)
append `((eq ,k ,v))))
t)
,@(cdr a1))
cases)))

[Common Lisp] lambda と書くのがめんどうなときに。{}

[] は CLSQL で使うから {} にしてみよう。

(set-macro-character
#\{
(lambda (stream char)
(declare (ignore char))
`(_ ,@(read-delimited-list #\} stream t))))

(set-macro-character #\} (get-macro-character #\)))
Stefil というテストフレームワークを使ったテスト
;;{} を使ったパターン
(deftest |test-{}| ()
(is (equal '((2) (3) (4)) (mapcar {list (1+ _)} '(1 2 3))))
(is (equal '(1 4 9) (mapcar {* _ _} '(1 2 3))))
(is (equal '((1 a "A") (2 b "B"))
(mapcar {list _z _y _x} '("A" "B") '(a b) '(1 2))))
(is (equal '(1 2 3)
(funcall {identity _rest} 1 2 3)))
(is (equal '(2 1 3 4)
(funcall {apply #'list _b _a _rest} 1 2 3 4)))
(is (equal "a"
(with-output-to-string (*standard-output*)
(funcall {princ _} #\a))))
(is (equal "abc"
(with-output-to-string (*standard-output*)
(funcall {(princ _x) (princ _y) (princ _z)} #\a #\b #\c)))))
;;{} を使わないパターン
(deftest |test-_| ()
(is (equal '((2) (3) (4)) (mapcar (_ list (1+ _x)) '(1 2 3))))
(is (equal '(1 4 9) (mapcar (_ * _x _x) '(1 2 3))))
(is (equal '((1 a "A") (2 b "B"))
(mapcar (_ list _z _y _x) '("A" "B") '(a b) '(1 2))))
(is (equal '(1 2 3)
(funcall (_ identity _rest) 1 2 3)))
(is (equal '(2 1 3 4)
(funcall (_ apply #'list _b _a _rest) 1 2 3 4)))
(is (equal "a"
(with-output-to-string (*standard-output*)
(funcall (_ princ _x) #\a))))
(is (equal "abc"
(with-output-to-string (*standard-output*)
(funcall (_ (princ _x) (princ _y) (princ _z)) #\a #\b #\c)))))
やっぱりマクロキャラクタを使った方がいいかな。マクロキャラクタの問題点はパッケージ内に閉じずグローバルだってとこ。だからこそ便利なんだろうけどね。

いや、そうなのかな? このマクロキャラクタと Forth の仕組みってよく似てるし、また考えてみよう。

2008/07/07

[Common Lisp] lambda と書くのがめんどうなときに。ちょっと考えなおした。

#_(* 2 _a) より (_ * 2 _a) でいいか。(_ (declare (optimize (speed 3))) (_ * 2 _a)) こっちは自然だな。いっそのこと [* 2 _a] とも思う(Arc!)が () に [] がまざるのに強烈な違和感を感じる(慣れるかな?)。(_ * 2 _) これでもいける。

(defmacro _ (&rest body)
(let ((syms
(sort
(remove-duplicates
(remove-if-not (lambda (x)
(and (symbolp x)
(head-p (symbol-name x) "_")))
(flatten body)))
#'string<=
:key #'symbol-name)))
(let ((rest (find '_rest syms :key #'symbol-name :test #'string=)))
(when rest
(setq syms (append (remove rest syms) `(&rest ,rest)))))
(if (consp (car body))
`(lambda ,syms
,@body)
`(lambda ,syms
,body))))

2008/07/06

[Common Lisp] Lisp isn't a language, it's a building material. — Alan Kay

Common Lisp も Lisp だから、好きなように使えばいいんだ。いままでなんとなく Common Lisp の流儀からそれないように、と思ってたけどそんな必要はない。だって Lisp だもん。
『LET OVER LAMBDA』を読んでふっきれた。

[Common Lisp] lambda と書くのがめんどうなときに

たまにはブログになんか書かないと。で、ありがちかもしれないが lambda と書くのがめんどうなときに ディスパッチマクロキャラクタ でちょっと楽してみよかな。#_ で始まるフォームを lambda フォームに変換する。_ で始まるシンボルがその lambda の引数。&rest_rest を使う。

使い方はこんなかんじ。

;;(mapcar (lambda (x) * x x) '(1 2 3 4))
(mapcar #_(* _x _x) '(1 2 3 4))
;; => (1 4 9 16)

;;(mapcar (lambda (a b) (format nil "~d-~d=~d" b a (- b a)))
(mapcar #_(format nil "~d-~d=~d" _b _a (- _b _a))
'(1 2 3 4)
'(10 20 30 40))
;; => ("10-1=9" "20-2=18" "30-3=27" "40-4=36")

;;(mapcar (lambda (&rest rest) (apply #'* rest)) '(1 2 3) '(4 5 6) '(7 8 9))
(mapcar #_(apply #'* _rest) '(1 2 3) '(4 5 6) '(7 8 9))
;; => (28 80 162)

'#_(* _x _x)
;; => (_ (* _X _X))

(macroexpand-1 '#_(* _x _x))
;; => (LAMBDA (_X) (* _X _X))

実装はこんなかんじ。

(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x)
(rec (cdr x) acc))))))
(rec x nil)))

(defgeneric head-p (whole part)
(:method ((whole string) (part string))
(let ((part-length (length part)))
(and (>= (length whole) part-length)
(string= whole part
:end1 part-length))))
(:method ((whole symbol) (part string))
(head-p (symbol-name whole) part)))

(defmacro _ (&rest body)
(let ((syms
(sort
(remove-duplicates
(remove-if-not (lambda (x)
(and (symbolp x)
(head-p (symbol-name x) "_")))
(flatten body)))
#'string<=
:key #'symbol-name)))
(let ((rest (find '_rest syms :key #'symbol-name :test #'string=)))
(when rest
(setq syms (append (remove rest syms) `(&rest ,rest)))))
(find '_rest '(_a _rest _b))
`(lambda ,syms
,@body)))

(set-dispatch-macro-character
#\# #\_
(lambda (stream subchar arg)
(declare (ignore subchar arg))
(let ((form (read stream t nil t)))
(if (consp (car form))
`(_ (progn ,@form))
`(_ ,form)))))