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

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

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)

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 "貘の鼻は長くて、羊はもこもこしている。
ところで貘の腹巻は白と黒のどちらだったろうか？")
;;=> ("貘" "鼻" "長く" "羊" "もこもこ" "し" "貘" "腹巻" "白" "黒" "どちら")

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 に教えてもらった。

『プログラミング Clojure』の「第4章 シーケンスと使ったデータの統合」を Common Lisp の SERIES でやってみる

まだ途中まで。

;;;; 『プログラミング Clojure』の「第4章 シーケンスと使ったデータの統合」を
;;;; Common Lisp の SERIES でやってみる。
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :series)
  (use-package :series))

(series::install)

;; (range 10)
(scan-range :below 10)
;;=> #Z(0 1 2 3 4 5 6 7 8 9)

;; (range 10 20)
(scan-range :from 10 :below 20)
;;=> #Z(10 11 12 13 14 15 16 17 18 19)

;; (range 1 5 2)
(scan-range :from 1 :below 25 :by 2)
;;=> #Z(1 3 5 7 9 11 13 15 17 19 21 23)

;; (repeat 5 1)
(subseries (series 1) 0 5)
;;=> #Z(1 1 1 1 1)

;; (repeat 10 "x")
(subseries (series "x") 0 10)
;;=> #Z("x" "x" "x" "x" "x" "x" "x" "x" "x" "x")

;; (take 10 (iterate inc 1))
(subseries (scan-fn t #'* #'1+) 0 10)
;;=> #Z(1 2 3 4 5 6 7 8 9 10)
(scan-range :from 1 :upto 10)
;;=> #Z(1 2 3 4 5 6 7 8 9 10)

;; (defn whole-numbers [] (iterate inc 1))
(defun whole-numbers ()
  (scan-range :from 1))

;; (take 20 (repeat 1))
(subseries (series 1) 0 20)
;;=> #Z(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)

;; (take 10 (cycle (range 3)))
(subseries (series 0 1 2) 0 10)
;;=> #Z(0 1 2 0 1 2 0 1 2 0)
(subseries (apply #'series (collect (scan-range :below 3))) 0 10)
;;=> #Z(0 1 2 0 1 2 0 1 2 0)

;; (interleave (whole-numbers) ["A" "B" "C" "D" "E"])
(collect-append (map-fn t #'list (whole-numbers) #z("A" "B" "C" "D" "E")))
;;=> (1 "A" 2 "B" 3 "C" 4 "D" 5 "E")
;; シリーズを返したいところ。

;; (interpose "," ["apples" "bananas" "grapes"])
;; パス。loop で。
(loop for (x xs) on '("apples" "bananas" "grapes")
     collect x if xs collect ",")
;;=> ("apples" "," "bananas" "," "grapes")

loop-finish

Common Lisp の loop からぬける loop-finish なんてのがあったのか。

(loop for i in '(1 3 5 4 8 7)
      if (evenp i)
        do (loop-finish)
      collect i)
;;=> (1 3 5)

(loop for i in '(1 3 5 4 8 7)
      if (evenp i)
        do (loop-finish)
      collect i
      finally (print "hello"))
;;=> (1 3 5)
;;   hello

いままで知らなかったから、こんなふうに書いてたよ。

(loop for i in '(1 3 5 4 8 7)
      if (evenp i)
        do (return x)
      collect i into x)
;;=> (1 3 5)

Clojure Leiningen @ Shibuya.lisp テクニカルトーク #5

Clojure の Leiningen で以前挫折をした。いやむしろ SLIME がちゃんと動かなくて嫌になった。

@making さんの LT "Clojure＋Leiningenで3分Hadoop" で Clojure の Leiningen がちゃんと動いくことの確信を得たのでリトライする。

目標は

• Leiningen でプロジェクトを作る。
• Leiningen で swank server を起動して、SLIMEでインタラクティブ開発。
• 単体実行 jar の作成。

シェルで次を実行。a はプロジェクト名。

lein new a

./a/project.clj を編集

• lein swank で swank server を起動するために :dev-dependencies を追加
• lein uberja で作る単体実行 jar のエントリポイントを指定する :main を追加

(defproject a "1.0.0-SNAPSHOT"
  :description "FIXME: write"
  :dependencies [[org.clojure/clojure "1.1.0"]
                 [org.clojure/clojure-contrib "1.1.0"]]
  :dev-dependencies [[leiningen/lein-swank "1.1.0"]]
  :main a.core)

シェルで次を実行し依存ライブラリの取得後、swank server を起動する。

lein deps
lein swank

Emacs から M-x slime-connect とすると、ちゃんと SLIME 動いた。補完もちゃんと動いた。別途、Emacs + SLIME まわりの設定は必要なので、それは後述する。

./a/src/a/core.clj を編集

• :gen-class を追加
• -main を追加

(ns a.core
  (:gen-class))

(defn -main [& args]
  (. javax.swing.JOptionPane (showMessageDialog nil "Hello World")))

シェルで

lein uberjar
chmod +x ./a-standalone.jar
./a-standalone.jar

以上、目標達成。

後述予定の Emacs + SLIME まわり。

github から swank-clojure と clojure-mode を git clone しておく。 ~/.emacs の設定は SBCL の最新 SLIME とかぶらないように無理をしている。うまく両立する方法はないものだろうか？おまけに Google App Engine を SLIME から起動しようとしたときの残骸も残ってる。

(defun clojure ()
  (interactive)
  (add-path "~/letter/clojure/lib/clojure-mode")
  (add-path "~/letter/clojure/lib/slime")
  (add-path "~/letter/clojure/lib/slime/contrib")
  (eval-after-load "slime"
    '(progn
       (slime-setup '(slime-repl
                      slime-fuzzy
                      slime-banner))
       (setq slime-complete-symbol*-fancy t)
       (setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)
       (global-set-key [(control ?\;)] 'slime-selector)
       (loop for (key command) in
             '(([(control ?c) ?\;]              slime-insert-balanced-comments)
               ([(control ?u) (control ?c) ?\;] slime-remove-balanced-comments)
               ([(control ?c) ?\;]              slime-insert-balanced-comments)
               ("\C-j"                          slime-eval-print-last-expression)
               ("\C-m"                          newline-and-indent)
               ("\C-i"                          slime-indent-and-complete-symbol))
             do (define-key slime-mode-map key command))))
  (setq swank-clojure-classpath
        '("~/letter/java/eclipse-workspace/moeopa-clj/src"
          "~/letter/java/eclipse-workspace/moeopa-clj/war/WEB-INF/classes"
          "~/letter/clojure/lib/swank-clojure/src"
          "~/letter/clojure/lib/clojure/clojure.jar"
          "~/letter/clojure/lib/clojure-contrib/clojure-contrib.jar"
          "~/letter/clojure/lib/appengine-clj/appengine-clj.jar"
          "~/letter/clojure/lib/compojure/compojure.jar"
          "~/letter/clojure/lib/compojure/deps/commons-codec-1.3.jar"
          "~/letter/clojure/lib/compojure/deps/commons-fileupload-1.2.1.jar"
          "~/letter/clojure/lib/compojure/deps/commons-io-1.4.jar"
          "~/letter/clojure/lib/compojure/deps/jetty-6.1.15.jar"
          "~/letter/clojure/lib/compojure/deps/jetty-util-6.1.15.jar"
          "~/letter/clojure/lib/compojure/deps/servlet-api-2.5-20081211.jar"
          "~/local/opt/appengine-java-sdk/lib/appengine-tools-api.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/appengine-local-runtime-shared.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/geronimo-el_1.0_spec-1.0.1.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/geronimo-jsp_2.1_spec-1.0.1.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/geronimo-servlet_2.5_spec-1.2.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/jsp/repackaged-appengine-ant-1.6.5.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/jsp/repackaged-appengine-ant-launcher-1.6.5.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/jsp/repackaged-appengine-commons-el-1.0.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/jsp/repackaged-appengine-commons-logging-1.1.1.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/jsp/repackaged-appengine-jasper-compiler-5.0.28.jar"
          "~/local/opt/appengine-java-sdk/lib/shared/jsp/repackaged-appengine-jasper-runtime-5.0.28.jar"
          "~/local/opt/appengine-java-sdk/lib/impl/appengine-api-labs.jar"
          "~/local/opt/appengine-java-sdk/lib/impl/appengine-api-stubs.jar"
          "~/local/opt/appengine-java-sdk/lib/impl/appengine-api.jar"
          "~/local/opt/appengine-java-sdk/lib/impl/appengine-local-runtime.jar"
          "~/local/opt/appengine-java-sdk/lib/impl/agent/appengine-agentruntime.jar"
          "~/letter/clojure/lib/programming-clojure/lib/ant.jar"
          "~/letter/clojure/lib/programming-clojure/lib/ant-launcher.jar"))
  (setq slime-lisp-implementations
        `((clojure
           ("java"
            "-classpath"
            ,(concat ".:classes:"
                     (mapconcat 'identity
                                (mapcar 'expand-file-name
                                        swank-clojure-classpath)
                                ":"))
            "clojure.main"
            "--repl")
           :init swank-clojure-init)))
  (load
   (expand-file-name "~/.emacs.d/elpa/package.el"))
  (package-initialize)
  (require 'clojure-mode)
  (require 'slime-autoloads)
  (slime)
  )

Leiningen からコマンド一発で Google App Engine の雛形プロジェクトが作成できたらいいのにな。

ということで making さんありがとうございました。

今回の Shibuya.lisp もよかったです。みなさんありがとうございました。

Common Lisp 的にはちょっとさびしかったな。

compute-effective-slot-definition の第三引数がリストであることの理由

どうして compute-effective-slot-definition の第三引数が direct-slot-definition ではなく direct-slot-definition のリストなんだろう？ と不思議に思っていた。リストだとディスパッチできないじゃないか、って。

Elephant のソースにこんなコメントを見つけた。

    ;; Effective slots are indexed only if the most recent slot definition
    ;; is indexed.  NOTE: Need to think more about inherited indexed slots

なるほど、継承関係で同じスロット名が複数あったときのためにリストなんだ。

(defclass a ()
  ((s1 :initarg :s1 :initform "a" :accessor s1)))

(defclass b ()
  ((s1 :initarg :s1 :initform "b" :accessor s1)))

(defmethod sb-mop:compute-effective-slot-definition :before
  ((class standard-class)
   slot-name
   direct-slot-definitions)
  (print "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%")
  (mapc #'describe direct-slot-definitions)
  (print "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"))

(defclass c (b a)
  ())

(make-instance 'c)

#|
"%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
#<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION S1>
  [standard-object]

Slots with :INSTANCE allocation:
  NAME                  = S1
  INITFORM              = "b"
  INITFUNCTION          = #<FUNCTION (LAMBDA ()) {1004B24749}>
  READERS               = (S1)
  WRITERS               = ((SETF S1))
  INITARGS              = (:S1)
  %TYPE                 = T
  %TYPE-CHECK-FUNCTION  = NIL
  %DOCUMENTATION        = NIL
  %CLASS                = #<STANDARD-CLASS B>
  ALLOCATION            = :INSTANCE
  ALLOCATION-CLASS      = NIL
#<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION S1>
  [standard-object]

Slots with :INSTANCE allocation:
  NAME                  = S1
  INITFORM              = "a"
  INITFUNCTION          = #<FUNCTION (LAMBDA ()) {1004B18B99}>
  READERS               = (S1)
  WRITERS               = ((SETF S1))
  INITARGS              = (:S1)
  %TYPE                 = T
  %TYPE-CHECK-FUNCTION  = NIL
  %DOCUMENTATION        = NIL
  %CLASS                = #<STANDARD-CLASS A>
  ALLOCATION            = :INSTANCE
  ALLOCATION-CLASS      = NIL

"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
|#

リストであることの理由は納得できたけど、どうにもスロットのクラスによってディスパッチしにくいことについては、納得いかない。

manardb でも苦肉のスペシャル変数で回避しているようだし。どうにかならないものでしょうか。

(defvar *mop-hack-effective-slot-definition-class* nil) ;; as compute-effective-slot-definition-initargs is not available portably

といいつつも、manardb でやっているように、なんとか回避できる手段があるところが Common Lisp のいいところだよね。