2010/10/31

お名前.com で info ドメインが 50 円だったから

ドメインを取った。

ついでに linode.com からさくらの VPS に移行した。

そして Emacs で T-Code をデフォルトにした。このエントリは T-Code で書いた。

「日本語入力 T-Code のススメ」〜 Google 日本語入力 TechTalk ライトニングトーク が素敵。

2010/10/30

(declaim (declaration あび))

SERIES のコードを読んでたら (declaim (declaration indefinite-extent)) みたなコードが出てきた。

CLSH の declaration によると、標準じゃないけど有効の宣言だよ、とコンパイラに教えてあげる機能らしい。

普通はこんなふうにワーニングがでる。

(defun foo ()
(declare (あび))
'foo)
; in: LAMBDA NIL
; (あび)
;
; caught WARNING:
; unrecognized declaration (あび)
;
; compilation unit finished
; caught 1 WARNING condition

次のように declaim するとワーニングが出なくなる。

(declaim (declaration あび))
(defun foo ()
(declare (あび))
'foo)

SERIES はこれと (defmacro defun ...) で、あやしげな黒魔術を展開しているみたい。

第5回ありえるえりあ勉強会 〜「Lisp脳」勉強会 〜

第5回ありえるえりあ勉強会 〜「Lisp脳」勉強会 〜 に行ってきた。

受付でおやつもらった。ありがとうございました。

いや、いろいろ面白かった。うん、本当に面白かったよ。

例のかけてたすやつ。普通 Common Lisp なら loop で書く。個人的には series でも書きたい。関数にするとあれなのでべたにする。

;; loop
(loop for x in '(10 20 30 40 50) for i from 0 sum (* x i))
;; => 400

;; series
(require :series)
(series::install)
(collect-sum (#M* (scan '(10 20 30 40 50)) (scan-range)))
;; => 400

これは Lisp 脳? 関数的? 手続的?

マクロ展開してみると正体が分かる。

;; (loop for x in '(10 20 30 40 50) for i from 0 sum (* x i))
(BLOCK NIL
(COMMON-LISP:LET ((X NIL) (#:LOOP-LIST-981 '(10 20 30 40 50)))
(DECLARE (TYPE LIST #:LOOP-LIST-981))
(COMMON-LISP:LET ((I 0))
(DECLARE (TYPE NUMBER I))
(COMMON-LISP:LET ((#:LOOP-SUM-982 0))
(DECLARE (TYPE NUMBER #:LOOP-SUM-982))
(TAGBODY
(SETQ X (CAR #:LOOP-LIST-981))
(SETQ #:LOOP-LIST-981 (CDR #:LOOP-LIST-981))
SB-LOOP::NEXT-LOOP
(SETQ #:LOOP-SUM-982 (+ #:LOOP-SUM-982 (* X I)))
(IF (ENDP #:LOOP-LIST-981)
(PROGN (GO SB-LOOP::END-LOOP))
NIL)
(SETQ X (CAR #:LOOP-LIST-981))
(SETQ #:LOOP-LIST-981 (CDR #:LOOP-LIST-981))
(SETQ I (1+ I))
(GO SB-LOOP::NEXT-LOOP)
SB-LOOP::END-LOOP
(RETURN-FROM NIL #:LOOP-SUM-982))))))

;; (collect-sum (#M* (scan '(10 20 30 40 50)) (scan-range)))
(COMMON-LISP:LET* (#:ELEMENTS-991
(#:LISTPTR-992 '(10 20 30 40 50))
(#:NUMBERS-997 (COERCE (- 0 1) 'NUMBER))
#:ITEMS-989
(#:SUM-984 0))
(DECLARE (TYPE LIST #:LISTPTR-992)
(TYPE NUMBER #:NUMBERS-997)
(TYPE NUMBER #:SUM-984))
(TAGBODY
#:LL-1000
(IF (ENDP #:LISTPTR-992)
(GO SERIES::END))
(SETQ #:ELEMENTS-991 (CAR #:LISTPTR-992))
(SETQ #:LISTPTR-992 (CDR #:LISTPTR-992))
(SETQ #:NUMBERS-997 (+ #:NUMBERS-997 (COERCE 1 'NUMBER)))
(SETQ #:ITEMS-989
((LAMBDA (#:V-986 #:V-985) (* #:V-986 #:V-985)) #:ELEMENTS-991
#:NUMBERS-997))
(SETQ #:SUM-984 (+ #:SUM-984 #:ITEMS-989))
(GO #:LL-1000)
SERIES::END)
#:SUM-984)

字面こそ GO だけど、構造化以前の GOTO 文。そして SETQ は代入。あと IF もあるね。

分岐、代入、ジャンプ。。。アセンブラ?

まさに http://www.geekpage.jp/blog/?id=2006/12/13 ということだね。

2010/10/28

考え方

  1. 感情を省みる。
  2. 論理づけする。

大抵の場合 1. の段階で省みるものがない。

2010/10/27

CL-MECHANIZE 続きの続き

@snmsts さんがやってくれたので、昨日の続き。 @snmsts さんありがとうございます。

で drakma:http-request はちゃんと文字列を返してくれるようになったけど、 sb-thread:with-mutex でエラーになるので、 sb-thread:with-recursive-lock にしようか迷いながら、 sb-thread:with-mutex を削除。


diff --git a/cl-mechanize.lisp b/cl-mechanize.lisp
index f40fbf0..5aea76f 100644
--- a/cl-mechanize.lisp
+++
b/cl-mechanize.lisp
@@ -134,11 +134,10 @@ Handles cookies and history automatically."
(defun submit (form)
"Submit a form."
(declare (type form form))
- (sb-thread:with-mutex (*state-mutex*)
- (fetch (puri:merge-uris (form-action form)
- (page-uri *page*))
- :method (form-method form)
- :parameters (form-inputs form))))
+ (fetch (puri:merge-uris (form-action form)
+ (page-uri *page*))
+ :method (form-method form)
+ :parameters (form-inputs form)))

(defun follow (link)
"Follow a link."

ようやく動いたけど、どうも挙動が怪しい。 (fetch "http://www.google.com") のリンクが印字されるんだよなぁ。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-mechanize)
(require :flexi-stream-jp))

(defpackage :try-cl-mechanize
(:use :cl :cl-mechanize))

(in-package :try-cl-mechanize)

(setf drakma:*drakma-default-external-format* :utf-8)

;; Do a google search
(progn
(fetch "http://www.google.com")
(let* ((page (get-page))
(search-form (car (page-forms page))))
(setf (form-inputs search-form)
'(("q" . "Common Lisp エイリアン")))
(submit search-form)
(format t "~A~%" (ppcre:all-matches-as-strings "<title>[a-z].*</title>"
(page-content page)))
(dolist (link (page-links page))
(format t "~A~%" (link-text link)))))

;; Traverse the DOM
(stp:do-recursively (n (page-dom (get-page)))
(print n))

2010/10/26

CL-MECHANIZE の続き

昨日のエラーは、 closure-html の html-parser.lisp の 58 行目で :utf-8 固定になってるのが原因。

レスポンスの Content-Type は "text/html; charset=Shift_JIS" で返ってきいるが、そんなものは見ていない。

さらに closure-common は Shift_JIS なんてサポートしてない。

さて、どうしよう。

いや、違うな。 flexi-streams が Shift_JIS に対応すれば動くんじゃないかな。

flexi-streams が Shift_JIS に対応してないので drakma が body をバイナリで返しちゃって、上記のようなことになっている。 drakma が body を文字列で返せば closure-common が Shift_JIS を知らなくても問題はず。

2010/10/25

CL-MECHANIZE

インストール

./clbuild/my-projects

# cl-mechanize
cl-mechanize get_git http://github.com/joachifm/cl-mechanize.git
$ ./clbuild install cl-mechanize cxml-stp closure-html

試してみる

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-mechanize))

(defpackage :try-cl-mechanize
(:use :cl :cl-mechanize))

(in-package :try-cl-mechanize)

(fetch "http://www.google.com")

が、エラー。。。

Corrupted UTF-8 input (initial byte was #b10000011)
[Condition of type RUNES-ENCODING:ENCODING-ERROR]

エンコーディングライブラリ統一してください。

いや、これはそういう問題じゃないだろうけど、あえて、エンコーディングライブラリ統一してください。

きっと @snmsts さんがやってくれるはず。期待してます。

2010/10/24

今日は Shibuya.lisp Hackathon #1

今日は Shibuya.lisp Hackathon #1 に行ってきた。

結局 Rucksack の改造をした。

まずは IO に mmap を使う。 30% くらい速くなったように思う。 mmap すごいな。

次はトランザクションの並列化。といっても、せめてリード処理だけは並列に行いたい、というだけ。でも、これは失敗。やったことが、単に書き込みが走ってなければ読み込みは複数スレッド走れるように、ロック処理を改造。で、それだけでは足りなかった。オブジェクトのデシリアライズが、1バイトのマーカーを読み、そのマーカーによって内容を読む、という流れになっている。マーカー読んでから内容を読み終るまでにスレッドの切り替えがあると、他のスレッドによってファイルポジションが変更されて、デシリアライズが破綻する。それとは関係なく serialize.lisp のコードは好きだな。

ちゃんとデシリアライズをロックすればいいのかもしれないが、そこまで時間がなかった。もうちょっと時間が長い方がいいな。

http://github.com/quek/rucksack

楽しかったな。またやりたい。

そして @machida さんと @komagata さんのエイリアンパーカーが楽しみでしょうがない。

2010/10/23

明日は Shibuya.lisp Hackathon #1

明日は Shibuya.lisp Hackathon #1 に行く予定。

何をしようかまだ迷っている。 Rucksack を改造しようか、 Rucksack みたいなものを作ろうか。

永続化ライブラリを作りたい。

Common Lisp の永続化ライブラリといえば Elephant, Rucsack, manardb などがある。

Elephant はなかなうまく動いてくれないのが悲しい。

Rucksack は遅い。mmap 使ってなくて、同時トランザクションは1つ。

manardb は mmap 使っていて速いけど、mmap できるサイズまでしか扱えない。

Common Lisp での実装じゃないけど Kyoto Cabinet は mmap できる範囲を越えると、普通のディスク IO を行なうようになっている。

あとは単に作ってみたい、MOP レベルでいろいろやるのは面白そう。スキップリストとか、分散とかも面白そう。

で、明日は何しようかな。

以上、ちゃんとした文章を書くのは放棄した。

2010/10/22

| sbcl

g000001 さんに教えてもらった。こんなのもできるんだねぇ。

~% echo "(print '(print '(princ 'Hello)))"
(print '(print '(princ 'Hello)))
~% echo "(print '(print '(princ 'hello)))" | sbcl --noinform --end-runtime-options --no-sysinit --no-userinit --noprint

(PRINT '(PRINC 'HELLO)) %
~% echo "(print '(print '(princ 'hello)))" | sbcl --noinform --end-runtime-options --no-sysinit --no-userinit --noprint | sbcl --noinform --end-runtime-options --no-sysinit --no-userinit --noprint

(PRINC 'HELLO) %
~% echo "(print '(print '(princ 'hello)))" | sbcl --noinform --end-runtime-options --no-sysinit --no-userinit --noprint | sbcl --noinform --end-runtime-options --no-sysinit --no-userinit --noprint | sbcl --noinform --end-runtime-options --no-sysinit --no-userinit --noprint
HELLO%

2010/10/21

Named-Readtables いいね

g000001 さんからいいと聞いていた Named-Readtables をようやく使ってみた。

Common Lisp のリーダマクロはいろいろいろいろだけど。。。 Named-Readtables はいいと思う。

下のコードはいろいろいろいろだけど。。。 Named-Readtables はいいような気がする。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :named-readtables))

(defpackage :string-reader
(:use :cl)
(:export #:syntax))

(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 (and (char= #\" c1 c2 c3)
(char/= #\" (peek-char nil stream nil #\? t)))
do (write-char c1))))

(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 |#"-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)
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#))
;; 次の2行をコメントアウトするか否か悩ましいところ
else if (char= #\~ c)
do (write-string "~~" out)
else
do (write-char c out))))))
`(format nil ,format ,@(reverse args)))))

(named-readtables:defreadtable string-reader:syntax
(:merge :common-lisp)
(:dispatch-macro-char #\# #\" '|#"-reader|))

(named-readtables:in-readtable string-reader:syntax)

(princ #"""Common Lisp のスペシャルオペレータの数は#,(loop for sym being the external-symbol in :common-lisp count (special-operator-p sym))個です。""")

(named-readtables:in-readtable :common-lisp)

ちょっとちゃんと書いて使ってみようかな、という気がしてきた。

2010/10/20

float を 3 つの整数で表現する

理屈はよく分からないけど float って 3 つの整数で表現できるんだね。 Common Lisp の integer-decode-float がそれをやってくれる。

こんな関数まで標準である Common Lisp って、やっぱり素敵。

(multiple-value-bind (significand exponent integer-sign) (integer-decode-float 0.12345)
(values significand exponent integer-sign
(* (scale-float (float significand) exponent) integer-sign)))
;; => 16569179
-27
1
0.12345

(multiple-value-bind (significand exponent integer-sign) (integer-decode-float -12.345)
(values significand exponent integer-sign
(* (scale-float (float significand) exponent) integer-sign)))
;; => 12944671
-20
-1
-12.345

2010/10/19

Common Lisp は動的型付け言語

Common Lisp は動的型付け言語。次のようにどんどん型が変っていく。

(setf x (make-array 0 :element-type 'character :adjustable t :fill-pointer 0))
;; => ""

(type-of x)
;; => (AND (VECTOR CHARACTER 0) (NOT SIMPLE-ARRAY))

(vector-push-extend #\あ x)
;; => 0

(setf t1 (type-of x))
;; => (AND (VECTOR CHARACTER 1) (NOT SIMPLE-ARRAY)) ; ほら型がかわった

(typep x t1)
;; => T

(vector-push-extend #\い x)
;; => 1

(setf t2 (type-of x))
;; => (AND (VECTOR CHARACTER 3) (NOT SIMPLE-ARRAY)) ; また型がかわった

(typep x t2)
;; => T

(typep x t1) ; もうこの型ではない。
;; => NIL

ね。動的でしょ?

2010/10/18

整数を表現するのに必要なビット数を求める

Common Lisp では integer-length を使う。こんな関数もあったんだね。知らんかった。

シリアライズ処理の際には重宝する。

(loop for i from -8 to 8
do (format t "~a => ~a~&" `(integer-length ,i) (integer-length i)))
;; (INTEGER-LENGTH -8) => 3
;; (INTEGER-LENGTH -7) => 3
;; (INTEGER-LENGTH -6) => 3
;; (INTEGER-LENGTH -5) => 3
;; (INTEGER-LENGTH -4) => 2
;; (INTEGER-LENGTH -3) => 2
;; (INTEGER-LENGTH -2) => 1
;; (INTEGER-LENGTH -1) => 0
;; (INTEGER-LENGTH 0) => 0
;; (INTEGER-LENGTH 1) => 1
;; (INTEGER-LENGTH 2) => 2
;; (INTEGER-LENGTH 3) => 2
;; (INTEGER-LENGTH 4) => 3
;; (INTEGER-LENGTH 5) => 3
;; (INTEGER-LENGTH 6) => 3
;; (INTEGER-LENGTH 7) => 3
;; (INTEGER-LENGTH 8) => 4

2010/10/17

よくないかもしれないけど、楽だから

こんなふうに名前がぶつかることを期待して書くのはよくないのかな。でも楽。マクロ使えなかったら、もっと綺麗に書きゃなかいけないんだろうな。 Common Lisp でよかった。

(defmacro define-write-method (name
(&rest lambda-list)
length
under-mmap-size
over-mmap-size
cross-over-mmap-size
return-value)
`(defmethod ,name ,lambda-list
(with-slots (base-stream file-length mmap-size sap position ext lock) stream
(with-recursive-spinlock (lock)
(let* ((length ,length)
(end-position (+ length position)))
(flet ((ensure-file-length ()
(let ((current-len file-length))
(when (< current-len end-position)
(stream-truncate stream
(if ext
(min mmap-size (ceiling (* current-len ext)))
end-position))))))
(cond ((< end-position mmap-size)
(ensure-file-length)
,under-mmap-size)
((<= mmap-size position)
,over-mmap-size)
(t
(ensure-file-length)
,cross-over-mmap-size))
(setf position end-position)
,return-value))))))

(define-write-method sb-gray:stream-write-sequence ((stream mmap-stream)
(buffer sequence)
&optional (start 0) end)
(if end (- end start) (length buffer))
(copy-vector-to-sap buffer start sap position length)
(progn
(file-position base-stream position)
(write-sequence buffer base-stream)
(setf file-length end-position))
(let ((mlen (- mmap-size position)))
(copy-vector-to-sap buffer start sap position mlen)
(file-position base-stream (1- mmap-size))
(write-sequence buffer base-stream :start (1- mlen) :end end))
buffer)

(define-write-method sb-gray:stream-write-byte ((stream mmap-stream) integer)
1
(setf (sb-sys:sap-ref-8 sap position) integer)
(progn
(file-position base-stream position)
(write-byte integer base-stream))
()
integer)

よくないかもしれないけど、楽だから

こんなふうに名前がぶつかることを期待して書くのはよくないのかな。でも楽。マクロ使えなかったら、もっと綺麗に書きゃなかいけないんだろうな。 Common Lisp でよかった。

(defmacro define-write-method (name
(&rest lambda-list)
length
under-mmap-size
over-mmap-size
cross-over-mmap-size
return-value)
`(defmethod ,name ,lambda-list
(with-slots (base-stream file-length mmap-size sap position ext lock) stream
(with-recursive-spinlock (lock)
(let* ((length ,length)
(end-position (+ length position)))
(flet ((ensure-file-length ()
(let ((current-len file-length))
(when (< current-len end-position)
(stream-truncate stream
(if ext
(min mmap-size (ceiling (* current-len ext)))
end-position))))))
(cond ((< end-position mmap-size)
(ensure-file-length)
,under-mmap-size)
((<= mmap-size position)
,over-mmap-size)
(t
(ensure-file-length)
,cross-over-mmap-size))
(setf position end-position)
,return-value))))))

(define-write-method sb-gray:stream-write-sequence ((stream mmap-stream)
(buffer sequence)
&optional (start 0) end)
(if end (- end start) (length buffer))
(copy-vector-to-sap buffer start sap position length)
(progn
(file-position base-stream position)
(write-sequence buffer base-stream)
(setf file-length end-position))
(let ((mlen (- mmap-size position)))
(copy-vector-to-sap buffer start sap position mlen)
(file-position base-stream (1- mmap-size))
(write-sequence buffer base-stream :start (1- mlen) :end end))
buffer)

(define-write-method sb-gray:stream-write-byte ((stream mmap-stream) integer)
1
(setf (sb-sys:sap-ref-8 sap position) integer)
(progn
(file-position base-stream position)
(write-byte integer base-stream))
()
integer)

2010/10/16

運動会なのではやくなるおまじない

今日は娘の小学校の運動会だったので、はやくなるおまじないを唱える。

CL-USER> (defmacro はやくなるおまじない (f)
`(define-compiler-macro ,f (&whole form &rest args)
(if (every #'constantp args)
(apply #',f args)
form)))
はやくなるおまじない
CL-USER> (defun fib (n)
(if (<= n 2)
1
(+ (fib (1- n))
(fib (- n 2)))))
FIB
CL-USER> (time (fib 40))
Evaluation took:
5.201 seconds of real time
5.172323 seconds of total run time (5.168323 user, 0.004000 system)
99.44% CPU
9,338,722,200 processor cycles
37,024 bytes consed

102334155
CL-USER> (はやくなるおまじない fib)
FIB
CL-USER> (time (fib 40))
Evaluation took:
0.000 seconds of real time
0.000000 seconds of total run time (0.000000 user, 0.000000 system)
100.00% CPU
972 processor cycles
0 bytes consed

102334155

2回目の (time (fib 40)) では 0.000 seconds of real time になってる。ちゃんとはやくなったね。

というのは嘘で、実際は time が実行される前のコンパイル段階で5秒以上かかっている。

娘もかけっこでは4番だった。でも、楽しそうでよかったよ。

いや、3番だったみたい。

2010/10/15

ひきこもる

(with-unlocked-packages (:common-lisp)
(loop for x being the external-symbol in :common-lisp
do (unexport x :common-lisp)))
;; => NIL

2010/10/14

あー、もう

(without-package-locks
(dolist (p (package-used-by-list :common-lisp))
(unuse-package :common-lisp p))
(delete-package :common-lisp))

な感じだよ。

2010/10/12

Series の collect-ignore

Series は遅延評価だから collect-ignore みたいな何もしない人が必要になるんだねぇ。

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

(defpackage :s
(:use :cl :series))

(in-package :s)

(series::install)

(let (x)
(map-fn t (lambda (n) (push n x)) (scan '(1 2 3)))
x)
;; => NIL

(let (x)
(collect-ignore (map-fn t (lambda (n) (push n x)) (scan '(1 2 3))))
x)
;; => (3 2 1)

ちなみに collect-ignore の定義は次のとおり。さっぱり分かる気がしない。

;; API
(defS collect-ignore (items)
"(collect-ignore series)

Like COLLECT, but any output that would have been returned is
discarded. In particular, no results are consed at all."

(fragl ((items t)) (nil) () () () () () () nil)
:trigger t)

series:iterate の中の方で collect-ignore が使われている。これが series:iterate と series:mapping の違いということなんだね。

(defmacro iterate-mac (var-value-list &rest body)
"Applies BODY to each element of the series"
`(collect-ignore (mapping ,var-value-list ,@ body)))

2010/10/11

もう一つの Tilde for SBCL のやり方 (sb-int:encapsulate)

Tilde for SBCL convenience にて SBCL で ~/xxx なパスを扱う方法が紹介されています。そこでは sb-impl::parse-namestring を上書きするようにして実装されています。

もう一つの方法として sb-int:encapsulate を使って ~/xxx なパスを扱えるようにしてみます。 sb-int:encapsulate については FUNCTION ENCAPSULATION IN SBCL で紹介されています。

(sb-int:encapsulate
'open :~
'(let* ((filename (car sb-int:arg-list))
(namestring (typecase filename
(pathname (namestring #p"~/a"))
(t filename))))
(when (and (<= 2 (length namestring))
(string= "~/" namestring :end2 2))
(setf (car sb-int:arg-list)
(merge-pathnames (subseq namestring 2) (user-homedir-pathname))))
(apply sb-int:basic-definition sb-int:arg-list)))

(with-open-file (in "~/.sbclrc")
(read-line in))

(with-open-file (in #p"~/.emacs")
(read-line in))

;; 元に戻すには↓
(sb-int:unencapsulate 'open :~)

こんな具合に sb-int:encapsulate を使えば既存の関数をくるみこんで、振舞いを変えてやることができます。

2010/10/10

Quicklisp のメモ

Quicklisp を使ってみたときのメモ。

私の環境が Debian パッケージの SBCL がインストールされている環境で clbuid の SBCL を使っている関係か、いくつが問題があったのでメモしておく。

#|
ASDF could not load sb-posix because Not an absolute pathname #P"~/.clc/systems/".
なんていうエラーがでた。
これは Debian の common-lisp-controller がおかしい(?)ような気がするので、
次のようにファイルを2つほど削除する。

% cd /etc/common-lisp/source-registry.conf.d
% sudo rm 02-common-lisp-controller-userdir.conf common-lisp-controller-userdir.conf


~/.emacs で slime-setup に slime-asdf があると asdf-utilities がないと怒られたので、
slime-asdf はコメントアウトした。

(slime-setup '(slime-repl
;;slime-asdf
slime-fancy
slime-indentation
slime-references
slime-tramp
slime-banner))
|#



;; インストール
(load "/tmp/quicklisp.lisp")
(quicklisp-quickstart:install)
(ql:add-to-init-file)

#|
(ql:add-to-init-file) で ~/.sbclrc に次が追加される。
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
|#



#|
あとは個人的なプロジェクトも追加したいのだけど、

You will be able to make your own private repositories of Quicklisp software (called dists), but it's not documented right now.

の意味がよく分からない。
|#

2010/10/09

cl-twitter で OAuth

cl-twitter で OAuth ってこれどあってるのか?

いきなり cl-twitter へのパッチ。


~/letter/lisp/clbuild/source/cl-twitter% darcs whatsnew
hunk ./elements.lisp 32
- (record-type-args name args)
+ (record-type-args ',name args)
hunk ./twitter.lisp 49
- url access-token (oauth:token-consumer (twitter-user-access-token *twitter-user*))
+ url access-token
+ :consumer-token (oauth:token-consumer (or access-token
+ (twitter-user-access-token *twitter-user*)))
+;; :consumer-token (oauth:token-consumer (or (getf (getf args :auth) :oauth)
+;; (twitter-user-access-token *twitter-user*)))
hunk ./twitter.lisp 154
- (oauth:token-consumer request-token)
- request-token))
+ request-token
+ :consumer-token (oauth:token-consumer request-token)))

OAuth するために http://twitter.com/apps で consumer key と consumer secret を取得する。その後、次のコードで動かせた。

#|
http://twitter.com/apps で consumer key と consumer secret を取得する
|#

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-twitter))

(defpackage :try-cl-twitter
(:use :cl))

(in-package :try-cl-twitter)

(setf twit::*consumer-key* "aaaaaaaaaaaaaaaaaa"
twit::*consumer-secret* "bbbbbbbbbbbbbbbbbbbbbbbbbbbb")

(setf (values url request-token)
(twit:oauth-make-twitter-authorization-uri))
;; => #<PURI:URI http://twitter.com/oauth/authorize?&oauth_token=ccccccccccccccccccccccccccc>
;;#<CL-OAUTH:REQUEST-TOKEN
;; :CONSUMER #<CL-OAUTH:CONSUMER-TOKEN
;; :KEY "aaaaaaaaaaaaaaaaaa"
;; :SECRET "bbbbbbbbbbbbbbbbbbbbbbbbbbbb"
;; :USER-DATA NIL
;; :LAST-TIMESTAMP 0>
;; :KEY "ccccccccccccccccccccccccccc"
;; :SECRET "ddddddddddddddddddddddddddddddddd"
;; :USER-DATA (("oauth_callback_confirmed" . "true"))
;; :CALLBACK-URI NIL
;; :VERIFICATION-CODE "verification_code"
;; :AUTHORIZED-P NIL>

;; url にブラウザでアクセスし PIN コードを↓に設定
(setf (oauth::request-token-verification-code request-token) "5512017")

;; request-token から access-token を
(twit:oauth-authenticate-user (oauth:token-key request-token))
;; => #<TWITTER-USER 'quek'>

(twit::twitter-user-access-token (twit::get-user "quek"))
;; => #<CL-OAUTH:ACCESS-TOKEN
;; :CONSUMER #<CL-OAUTH:CONSUMER-TOKEN
;; :KEY "aaaaaaaaaaaaaaaaaa"
;; :SECRET "bbbbbbbbbbbbbbbbbbbbbbbbbbbb"
;; :USER-DATA NIL
;; :LAST-TIMESTAMP 0>
;; :KEY "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"
;; :SECRET "ffffffffffffffffffffffffffffffff"
;; :USER-DATA (("user_id" . "4344931") ("screen_name" . "quek"))
;; :SESSION-HANDLE NIL
;; :EXPIRES NIL
;; :AUTHORIZATION-EXPIRES NIL
;; :ORIGIN-URI "http://twitter.com/oauth/access_token">

;; 以上で、アクセストークンが取得できた。



;; 次からは consumer key, consumer secret, access-token key, access-token secret で
(setf access-token (oauth:make-access-token
:consumer (oauth:make-consumer-token
:key "aaaaaaaaaaaaaaaaaa"
:secret "bbbbbbbbbbbbbbbbbbbbbbbbbbbb")
:key "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"
:secret "ffffffffffffffffffffffffffffffff"))

(setf twit:*twitter-user* (twit:twitter-op :user-show :id "quek" :auth (list :oauth access-token)))
;; => #<TWITTER-USER 'quek'>

(setf (twit::twitter-user-access-token twit:*twitter-user*) access-token)q

(twit:friends-timeline)

(twit:update "まみむめも♪")

あってる気がしない。もっとスマートな方法は?

2010/10/08

cl-typesetting で日本語出力

ちょっと前のことだけど cl-typesettingCL-PDF)で日本語出力できるようにしてみた。

http://github.com/quek/cl-pdf-jp

かろうじて日本語フォントが使える程度だけど、ないよりはましでしょ?

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-typesetting))

(defpackage :try-cl-typesetting
(:use :cl :typeset))

(in-package :try-cl-typesetting)

(defun hello (&optional (file #P"/tmp/hello.pdf"))
(pdf:with-document ()
(pdf:with-page ()
(pdf:with-outline-level ("Example" (pdf:register-page-reference))
(pdf:set-line-width 0.1)
(let ((content
(compile-text ()
(vspace 100)
(paragraph (:h-align :left :font "GothicBBB-Medium" :font-size 40 :color '(0.0 0 0.8))
"ばーあ。羊は「かる」。ばーばー羊。永い羊。ばーばー羊。永い羊。ばーばー羊。永い羊。ばーばー羊。永い羊。"
:eol
(vspace 2)
(hrule :dy 1)
(with-style (:font "Times-Italic" :font-size 26)
"The cool Common Lisp typesetting system")
(vspace 50)
(with-style (:font "Ryumin-Light" :font-size 30)
"こんにちは、市民!ばくです。")
(with-style (:font "Times-Roman" :font-size 30)
"Hello World!")
(with-style (:font "GothicBBB-Medium" :font-size 30)
"こんにちは、市民!ばくです。")
(with-style (:font "Ryumin-Light" :font-size 30)
"こんにちは、市民!ばくです。")
(vspace 50)
(with-style (:font "Helvetica" :font-size 12)
"hello" (typeset::dotted-hfill) "4.2" :eol
"hello world" (typeset::dotted-hfill) "4.2.4.2"))
(paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
"hello" (typeset::dotted-hfill) "4.2" :eol
"hello world" (typeset::dotted-hfill) "4.2.4.2")
(vspace 50)
(paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
"hello" (typeset::dotted-hfill :pattern-spacing 0.6) "4.2" :eol
"hello world" (typeset::dotted-hfill :pattern-spacing 0.6) "4.2.4.2")
(vspace 50)
(paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
"hello" (typeset::dotted-hfill :char-pattern ".+" :pattern-spacing 0) "4.2" :eol
"hello world" (typeset::dotted-hfill :char-pattern ".+" :pattern-spacing 0) "4.2.4.2"))))
(typeset::draw-block content 20 800 545 700))))
(pdf:write-document file))
(asdf:run-shell-command (format nil "evince ~a" file)))

2010/10/07

CLSQL で MySQL につなぐ

いつも忘れるのでメモ。

#|
cffi ではなく uffi を使うこと。
|#

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

(defpackage :clsqlを使う
(:use :cl :clsql :clsql-sys))

(in-package :clsqlを使う)

(defun test ()
(connect '("localhost" "blog_development" "root" "") :database-type :mysql)
(execute-command "set character_set_client='utf8'")
(execute-command "set character_set_connection='utf8'")
(execute-command "set character_set_results='utf8'")
(print (query "show variables like 'char%'"))
(print (query "select * from posts"))
(disconnect))

#|
disconnect でエラーになったので

diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp
index eef9f42..76803e9 100644
--- a/db-mysql/mysql-sql.lisp
+++ b/db-mysql/mysql-sql.lisp
@@ -219,7 +219,8 @@

(defmethod database-disconnect ((database mysql-database))
(mysql-close (database-mysql-ptr database))
- (setf (database-mysql-ptr database) nil)
+ ;;(setf (database-mysql-ptr database) nil)
+ (setf (database-mysql-ptr database) (uffi:make-null-pointer 'mysql-mysql))
t)

(defmethod database-execute-command (sql-expression (database mysql-database))
|#

2010/10/06

Common Lisp でメール送信

g000001 さんに元となるソースコードをもらって、 Common Lisp でメール送信するする関数を書いてみた。

cl-smtp を使ったけど、その内部で使われている FLEXI-STREAMS が iso-2022-jp に対応していない。そこは適当にだまくらかした。

(eval-when (:compile-toplevel :load-toplevel :execute)
(asdf:oos 'asdf:load-op :trivial-shell)
(asdf:oos 'asdf:load-op :cl-smtp))

(defpackage :メール送信
(:use :cl))

(in-package :メール送信)

(defun encode-subject (subject)
(let ((subject (trivial-shell:shell-command
"nkf -M"
:input (trivial-shell:shell-command
"nkf -j"
:input subject))))
(subseq subject 0 (1- (length subject)))))
;; (encode-subject "あいう")

(defun encode-message (message)
(trivial-shell:shell-command "nkf -j"
:input (format nil "~a~%" message)))
;; (encode-message "あいう")

;; flexi-streams をだます。
(pushnew '(:iso-2022-jp . :utf-8) flex::+name-map+ :test #'equal)

(defun send-mail (host from to subject message)
(let ((subject (encode-subject subject))
(message (encode-message message)))
(cl-smtp:send-email host from to subject message
:external-format :iso-2022-jp
:extra-headers '(("Content-Transfer-Encoding" "7bit")))))
#|
(send-mail "localhost" "read.eval.print+from@gmail.com" "read.eval.print+to@gmail.com" "テスト" "テストです。")
|#

2010/10/05

(series::install) して (declare (optimizable-series-function)) する

(series::install) して (declare (optimizable-series-function)) すると下のコードのようにおもしろいことがおきる。

(series::install) で defun は SERIES::DEFUN になり、 (declare (optimizable-series-function)) で SERIES::DEFUN したものは、マクロ展開されてしまう。

始めて collect-xxx 系をマクロ展開してみたときの驚きは忘れられない。

(series::install)

(defun scan-string-bytes (string &optional (external-format :default))
(declare (optimizable-series-function))
(scan (sb-ext:string-to-octets string :external-format external-format)))

(scan-string-bytes "あいう")
;; => #Z(227 129 130 227 129 132 227 129 134)

(functionp #'scan-string-bytes)
;; => T
(macro-function 'scan-string-bytes)
;; => NIL
(macroexpand-1 '(scan-string-bytes "あいう"))
;; => (SCAN-STRING-BYTES "あいう")
;; NIL

(collect-first (scan-string-bytes "あいう"))
;; => 227

(macroexpand-1 '(collect-first (scan-string-bytes "あいう")))
;; => (COMMON-LISP:LET* ((#:OUT-940
;; (STRING-TO-OCTETS "あいう" :EXTERNAL-FORMAT :DEFAULT)))
;; (COMMON-LISP:LET (#:ELEMENTS-941
;; #:LISTPTR-938
;; #:TEMP-937
;; (#:LIMIT-936 0)
;; (#:INDEX-935 -1)
;; #:LSTP-934
;; (#:ITEM-933 NIL))
;; (DECLARE (TYPE LIST #:LISTPTR-938)
;; (TYPE SERIES::VECTOR-INDEX+ #:LIMIT-936)
;; (TYPE SERIES::-VECTOR-INDEX #:INDEX-935)
;; (TYPE BOOLEAN #:LSTP-934)
;; (TYPE (SERIES::NULL-OR T) #:ITEM-933))
;; (LOCALLY
;; (DECLARE (TYPE ARRAY #:TEMP-937))
;; (IF (SETQ #:LSTP-934 (LISTP #:OUT-940))
;; (SETQ #:LISTPTR-938 #:OUT-940
;; #:TEMP-937 #())
;; (LOCALLY
;; (DECLARE (TYPE ARRAY #:OUT-940))
;; (SETQ #:TEMP-937 #:OUT-940)
;; (SETQ #:LIMIT-936
;; (SERIES::ARRAY-FILL-POINTER-OR-TOTAL-SIZE #:OUT-940))))
;; (TAGBODY
;; #:LL-947
;; (IF #:LSTP-934
;; (PROGN
;; (IF (ENDP #:LISTPTR-938)
;; (GO SERIES::END))
;; (SETQ #:ELEMENTS-941 (CAR #:LISTPTR-938))
;; (SETQ #:LISTPTR-938 (CDR #:LISTPTR-938)))
;; (PROGN
;; (INCF #:INDEX-935)
;; (LOCALLY
;; (DECLARE (TYPE ARRAY #:OUT-940)
;; (TYPE SERIES::VECTOR-INDEX #:INDEX-935))
;; (IF (>= #:INDEX-935 #:LIMIT-936)
;; (GO SERIES::END))
;; (SETQ #:ELEMENTS-941
;; (THE SERIES::*TYPE*
;; (ROW-MAJOR-AREF #:OUT-940 #:INDEX-935))))))
;; (SETQ #:ITEM-933 #:ELEMENTS-941)
;; SERIES::END)
;; #:ITEM-933)))
;;T

2010/10/04

-

毎日ブログを書いてみようかな、と思ったので、書いてみる。内容よりも継続することを重視で。

たいていの言語には単項演算子の - と二項演算子の - の2つがある。 Common Lisp には関数の - が1つだけある。

(- 3)
;; => -3
(- 3 2)
;; => 1

;; (- 3) は油断するとこんなふうに書いてしまう。
(- 0 3)
;; => -3