2010/04/30

適当な画像ファイルを用意する

適当な画像ファイルがいくつか必要になった。

Common Lisp の Vecto を使って作った。

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

(defpackage #:vvv
(:use #:cl #:vecto))

(in-package #:vvv)

(defparameter *font*
"/usr/share/fonts/truetype/vlgothic/VL-PGothic-Regular.ttf")

(defun foo (file str)
(with-canvas (:width 90 :height 90)
(set-font (get-font *font*) 60)
(draw-centered-string 35 25 str)
(save-png file)))

(defun main (from to)
(loop for i from (char-code from) to (char-code to)
for c = (code-char i)
do (foo (format nil "/tmp/~a.png" c) (string c))))

(main #\A #\E)
(main #\ま #\も)

(incf vocto)

2010/04/18

Common Lisp から Yahoo の日本語形態素解析を使う

XML を XMLS に変換すれば destructuring(destructuring-bind と loop) なバインドで簡単に処理できる。

  • DRAKMA で Web API をたたいて XML を取得。
  • Closure XML で XMLS に変換。これで S 式の世界。
  • destructuring-bind で word_list 部分をとりだす。
  • loop で形態素を集める。

これだけ簡単だと SAX とか DOM とか XPath なんてとても使う気になれないよね。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :drakma)
(require :cxml)
(require :cl-ppcre))

(defvar *yahoo-appid* "アプリケーションID")
(defvar *yahoo-url* "http://jlp.yahooapis.jp/MAService/V1/parse")

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

(defun yahoo-http-request (text)
(drakma:http-request
*yahoo-url*
:method :post
:parameters `(("appid" . ,*yahoo-appid*)
("filter" . "1|2|5|9|10") ; 形容詞 形容動詞 連体詞 名詞 動詞
("sentence" . ,text))))

(defun text-to-words (text)
(destructuring-bind (result-set
schema-location
(ma-result
_
total-count
filtered-count
word-list))
(cxml:parse (yahoo-http-request text) (cxml-xmls:make-xmls-builder))
(declare (ignorable result-set schema-location ma-result _
total-count filtered-count))
(print word-list)
(loop for (_a _b (_c _d word)) in (cddr word-list)
collect word)))


(text-to-words "貘の鼻は長くて、羊はもこもこしている。
ところで貘の腹巻は白と黒のどちらだったろうか?"
)
;;=> ("貘" "鼻" "長く" "羊" "もこもこ" "し" "貘" "腹巻" "白" "黒" "どちら")

2010/04/01

Common Lisp で 1 を返す関数 lambda constantly *

;; 次の3つは 0 を返す関数
(lambda () 1)
(constantly 1)
#'*

;; 昨日の↓は
(subseries (scan-fn t (lambda () 1) #'1+) 0 10)

;; こう書ける
(subseries (scan-fn t #'* #'1+) 0 10)

ただし (constantly 1) 以外は引数なしでコールしなければならない。 (constantly 1) はどんな引数を渡しても1が返る。

SBCL での constantly の定義がこれ。

(defun constantly (value)
#!+sb-doc
"Return a function that always returns VALUE."
(lambda ()
;; KLUDGE: This declaration is a hack to make the closure ignore
;; all its arguments without consing a &REST list or anything.
;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to
;; screw around with this kind of thing. -- WHN 2001-04-06
(declare (optimize (speed 3) (safety 0)))
value))

すごいよね?

constantly の存在を今日まで知らなくて g000001 に教えてもらった。