Linux 環境での Clozure CL で日本語パス名

Linux 環境での Clozure CL で日本語パス名を扱うには次のコードが必要みたい。 Mac と Win はデフォルトで大丈夫そう。

(ccl::set-pathname-encoding-name :utf-8)

いまさらだけど Clozure CL は Windows でもスレッドが使える

Clozure CL(CCL)なの。いや、以前からそんな話はきいてたんだけど何故かあまり気にしていなかった。いまさらながら、いじってみると確かにスレッドが使える。 Hunchentoot もすんなり動いた。これで簡単に Windows 上で Web サーバがたてられるw

あとは CP932 だけですね♪

おさらいをかねて初期化ファイルを。 c:/Users/ancient/ccl-init.lisp

;;;; -*- lisp -*-

;;; 最適化
#+nil
(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)
                   (compilation-speed 3)))
#+nil
(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)
                   (compilation-speed 0)))


;;; 文字コード
(setf ccl:*default-external-format*
      (ccl:make-external-format :character-encoding :utf-8
                                :line-termination :dos)
      ccl:*default-file-character-encoding* :utf-8
      ccl:*default-socket-character-encoding* :utf-8)


;;; asdf
(require :asdf)

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "home:letter;lisp;lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))

;; clbuild
;;(pushnew (translate-logical-pathname "home:letter;lisp;clbuild;systems;")
;; asdf:*central-registry*)
;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "home:letter;lisp;clbuild;source;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))


;; require で asdf:oos する
(defun asdf-module-provider-function (module)
  (when (asdf:find-system module nil)
    (asdf:oos 'asdf:load-op module)
    t))
(pushnew 'asdf-module-provider-function
         ccl::*module-provider-functions*)

(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file))
  (handler-case (call-next-method o c)
    (#+sbcl sb-ext:invalid-fasl
      #+allegro excl::file-incompatible-fasl-error
      #+lispworks conditions:fasl-error
      #+cmu ext:invalid-fasl
      #-(or sbcl allegro lispworks cmu) error ()
      (asdf:perform (make-instance 'asdf:compile-op) c)
      (call-next-method))))
 

Clozure CL 本体の他に、clbuid が使いたいので cygwin とか darcs とか git とか svn とかも必要。

./clbuild install hunchentoot

して、

CL-USER> (require :hunchentoot)
CL-USER> (hunchentoot:start (make-instance 'hunchentoot:acceptor :port 1234))

http://localhost:1234/ にアクセス♪

もちろん Meadow と

./clbuild install slime

も必要。ついでに ~/.emacs の SLIME まわりの設定。

(require 'path-util) ; add-path用

(add-path "~/letter/lisp/clbuild/source/slime")
(add-path "~/letter/lisp/clbuild/source/slime/contrib")
(setq slime-lisp-implementations
      `((ccl ("/Users/ancient/local/opt/ccl/wx86cl.exe")
             :coding-system utf-8-unix)
        (sbcl ("sbcl")
              :coding-system utf-8-unix)
        (clisp ("clisp") :coding-system utf-8-unix)))
(require 'slime-autoloads)
(add-hook 'lisp-mode-hook
          (lambda ()
            (cond ((not (featurep 'slime))
                   (require 'slime)
                   (normal-mode)))))
(setq slime-truncate-lines nil)
(setq slime-enable-evaluate-in-emacs t)
(add-hook
 'slime-mode-hook
 (lambda ()
   (global-set-key [(control ?\;)] 'slime-selector)
   (loop for (key command) in
         '(("\C-m" newline-and-indent)
           ("\C-i" slime-indent-and-complete-symbol))
         do (define-key slime-mode-map key command))))
(add-to-list 'auto-mode-alist '("\\.asd$" . common-lisp-mode))
(eval-after-load "slime"
  '(progn
    (slime-setup '(slime-repl slime-asdf slime-fancy slime-banner))
    (setq slime-complete-symbol*-fancy t)
    (setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)))

cl-openid

ふと OpenID を使ってみようと思った。 Common Lisp にもちゃんと OpenID のライブラリがあった。 CL-OpenID

サンプルがついているのだけど、最近の Hunchentoot では次のように修正する必要があった。 get-parameters と request-uri に hunchetoot::*request* を渡してあげる。

in directory ./examples:
              Modified                relying-party.lisp
41
-        (alist-to-lol (get-parameters))
+        (alist-to-lol (get-parameters hunchentoot:*request*))
52
-        (alist-to-lol (get-parameters))
+        (alist-to-lol (get-parameters hunchentoot:*request*))
65
-                (alist-to-lol (get-parameters))
+                (alist-to-lol (get-parameters hunchentoot:*request*))
85
-                          *relying-party* (get-parameters) ; The incoming message alist consists of GET parameters.
-                          (merge-uris (request-uri) (root-uri *relying-party*))))) ; Figuring out actual request URI may be more complicated with proxies
+                          *relying-party* (get-parameters hunchentoot:*request*) ; The incoming message alist consists of GET parameters.
+                          (merge-uris (request-uri hunchentoot:*request*) (root-uri *relying-party*))))) ; Figuring out actual request URI may be more complicated with proxies

あとは、こんな感じで動かして http://xxx.xxxx.xx:1234/cl-openid/ にアクセスする。

(require :cl-openid)
(require :cl-openid.examples)

(cl-openid.example-rp::init-relying-party
 "http://xxx.xxxx.xx:1234/" "/cl-openid/")

(setq hunchentoot:*show-lisp-errors-p* t)
(hunchentoot:start (make-instance 'hunchentoot:acceptor :port 1234))

examples/relying-party.lisp を見る。 relying-party のインスタンスを作っておく。 handle-openid-request では cond で場合わけ。ふむ、使うぶんには簡単そうだ。

SBCL にも並列処理の流れ

SBCL の 1.0.29.31 に "Lock-free thread safe queue" が追加された。とてもライブラリ的なものなに処理系に含まれるなんて、並列処理の流れなんだろうな。メッセージパッシングのためのメールボックスの下地なんだろう。いまどきの欲しい機能ではある。

いまのところ queue なので要素の取り出しは dequeue しかない。残念ながら Erlang のパターンマッチングによる選択的な受信は実現できなさそう。

(require :sb-queue)

(defvar *queue* (sb-queue:make-queue))

(sb-queue:enqueue 'foo *queue*)
(sb-queue:enqueue 'bar *queue*)

(sb-queue:dequeue *queue*)              ; => FOO, T
(sb-queue:dequeue *queue*)              ; => BAR, T

スーツとトンボ

十数年前に買ったスーツがかなりくたびれてきたので、新しくスーツを買った。スーツは客先に行くときだけ。だいたい年の半分は客先。なねど十数年といっても実質は6年ほど。さらに夏用なのでその半分かな。

最近のスーツは細身だね。ノータックだし。涼しげな工夫がいろいろこらされているところはよい。

しかし、スーツは仕事用の作業服なんだよな。そのために何万も出費してしまうのは納得いかないw

子供が小学校から連れてかえったヤゴの最後の一匹が無事にトンボになって飛んでいったらしい。よかった。

Erik Naggum

Zach's Journal - RIP, Erik Naggum

ongoing Erik Naggum, R.I.P.

Erik Naggum, 1965-2009 RIP

今日のこと

どうして課なんていう古臭くスタティックなものにこだわるのかが分からない。いや、あるめんでは今日気がついた。それを理解することはできないけど。スタティックな組織単位じゃ現状に対応しきれない。 5人いたら、(1 1 1 1 1) (2 1 1 1) (2 2 1) (3 1 1) (3 2) (4 1) (5) のパターン。 10人なら、20人なら。いまの規模では20人の視点がまだ必要だと思う。都度プロジェクト毎に柔軟に組織課すればいい。課長とかの役職は固定であってもいいが、そのメンバーを固定にする必要はないと思う。あぁ、いや、固定にしてほしい人たちがいたから今の状況になってるんだよね。また言うがその気持ちはわからないけど。マイノリティ。スタティックが好きな人もいるんだよね。そして私はダイナミックが好きだ。 Common Lisp が好き。

と書いてはみたが、分からなと好き以外については根拠がない。分析も裏付けも深い考察もシミュレーションも現状把握もない。

McCLIM で PNG フォーマットの画像を表示する

McCLIM で画像を表示するには make-pattern-from-bitmap-file で画像ファイルを読み込み、draw-pattern* で描画すればいい。 bitamp と jpeg は対応したが png は対応していなかった。 CL-PNG を使って png 対応する。

新しい画像フォーマットに対応するためには clim-extensions:define-bitmap-file-reader でファイルを読み込んで (unsigned-byte 32) の2次元配列を返せばいいらしい。中身は RGB なんだけど、残りの 8 バイトが何だかよく分からない。そこはスルー。

mcclim/Extensions/Bitmap-formats/jpeg.lisp を参考しながら実装する。

(require :mcclim)
(require :png)

(in-package :clim-user)

(defparameter *png-file*
  (merge-pathnames "letter/lisp/clbuild/source/cl-png/test/images/butterfly8.png"
                   (user-homedir-pathname)))

(clim-extensions:define-bitmap-file-reader :png (pathname)
  (with-open-file (in pathname :element-type '(unsigned-byte 8))
    (let* ((png (png:decode in))
           (height (png:image-height png))
           (width (png:image-width png))
           (data (make-array (list height width)
                             :element-type '(unsigned-byte 32))))
      (dotimes (y height)
        (dotimes (x width)
          (let ((red (aref png y x 0))
                (green (aref png y x 1))
                (blue (aref png y x 2)))
            (setf (aref data y x)
                  (dpb red (byte 8 0)
                       (dpb green (byte 8 8)
                            (dpb blue (byte 8 16)
                                 (dpb (- 255 0) (byte 8 24) 0))))))))
      data)))

(define-application-frame my-frame ()
  ()
  (:pane
   (make-pane 'application-pane
              :display-function
              (lambda (frame stream)
                (declare (ignore frame))
                (let ((pattern (make-pattern-from-bitmap-file
                                *png-file* :format :png)))
                  (draw-pattern* stream
                                 pattern
                                 0 0))))))

;;(run-frame-top-level (make-application-frame 'my-frame))

グイン・サーガ

グイン・サーガの新刊を買った。書店で平積みされているのを見たときはなんとも不思議な感じがした。

McCLIM テーブルフォーマット

「グリッドビューみたいなのはどうするんかなぁ。」の件だけど、ちゃんとテーブルフォーマットあったよ。うん、確かにあったよ。 仕様はこちら。

ただプレゼンテーションと両立する方法がにわかりは分からなかった。いや、仕様を見ればちゃんと書いてある気がするけど、いまは英語を読む気力がない。あと幅の指定とかも。

(defun table-format (stream timeline)
  (fresh-line stream)
  (formatting-table (stream :x-spacing '(1 :character))
    (loop for tweet in timeline
          do (formatting-row (stream)
               (formatting-cell (stream)
                 (princ (twitter:twitter-user-screen-name
                         (twitter:tweet-user tweet))
                        stream))
               (formatting-cell (stream)
                 (princ (twitter:tweet-text tweet) stream))
               (formatting-cell (stream)
                 (princ (dispay-create-at tweet) stream))))))


(defun display-timeline (frame pane)
  (with-slots (timeline) frame
    (table-format pane timeline)))

;; (defun display-timeline (frame pane)
;;   (with-slots (timeline) frame
;;     (mapc (lambda (tweet)
;;             (updating-output (pane :unique-id tweet)
;;               (present tweet 'twitter:tweet :stream pane)
;;               (terpri pane)))
;;           timeline)))

(define-application-frame twitter-frame ()
  ((timeline :initform nil :accessor timeline)
   (last-id :initform 1 :accessor last-id)
   (worker))
  (:menu-bar t)
  (:panes (timeline-pane
           :application
           :incremental-redisplay t
           :display-function 'display-timeline)
          (text-editor
           :text-editor
           :space-requirement (make-space-requirement :width 900))
          (entry-button
           :push-button
           :label "投稿する"
           :activate-callback
           (lambda (button)
             (declare (ignore button))
             (execute-frame-command *application-frame*
                                    `(com-update-status)))))
  (:layouts (default (vertically (:width 900 :height 600)
                       timeline-pane
                       (horizontally (:height 50) text-editor entry-button)))))

McCLIM で twitter クライアントを作ってみた

昨日は clg で作ったので今日は McCLIM で作ってみた。作ったといっても昔書きちらしてたのを整理したという感じ。

やはり Common Lisper としては clg より McCLIM の方が落ち着く。見た目がしょぼかろうと、複雑怪奇であろうとやはり Common Lisp でコードを書いているという実感が嬉しいのかな。

いやそれほど複雑怪奇じゃないな。方向性がちょっと違うだけだよ。

define-presentation-type, define-presentation-method っていいね。これがあるからこそ画面上のそこにオブジェクトが「ある」と感じられる。

タイマーとかわかんなかったからスレッドでやっちゃた。グリッドビューみたいなのはどうするんかなぁ。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :quek)
  (require :mcclim)
  (require :mcclim-freetype)
  (require :mcclim-uim)
  (require :cl-twitter)
  (require :net-telent-date))

(defpackage :mcclim-twitter-html-client
    (:use :clim :clim-lisp))

(in-package :mcclim-twitter-html-client)

;; 文字コードは UTF-8 で
(setf drakma:*drakma-default-external-format* :utf-8)

(defvar *auth*
  (with-open-file (in (merge-pathnames ".twitter.lisp"
                                       (user-homedir-pathname)))
    (read in))
  "Basic 認証のパラメータを取得する。~/.twitter.lisp の中身は
(\"username\" \"password\")")

(defun dispay-create-at (tweet)
  (multiple-value-bind (second minute hour date month)
      (decode-universal-time
       (net.telent.date:parse-time (twitter:tweet-created-at tweet)))
    (format nil "~02,'0d/~02,'0d ~02,'0d:~02,'0d:~02,'0d"
            month date hour minute second)))

(defun update-timeline (frame)
  (with-output-to-string (*standard-output*)
    (with-slots (timeline last-id) frame
      (let ((update (twitter:friends-timeline :since-id last-id)))
        (when update
          (setf last-id (twitter:tweet-id (car update)))
          (setf timeline (append update timeline)))))))

(defun update-status (new-status)
  (twitter:send-tweet new-status))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-presentation-type twitter:tweet ()))

(define-presentation-method present (object (type twitter:tweet)
                                            stream view &key)
  (format stream "~15a ~a ~a"
          (twitter:twitter-user-screen-name
                                    (twitter:tweet-user object))
          (twitter:tweet-text object)
          (dispay-create-at object)))

(defun display-timeline (frame pane)
  (with-slots (timeline last-id) frame
    (mapc (lambda (tweet)
            (updating-output (pane :unique-id tweet)
              (present tweet 'twitter:tweet :stream pane)
              (terpri pane)))
          timeline)))

(define-application-frame twitter-frame ()
  ((timeline :initform nil :accessor timeline)
   (last-id :initform 1 :accessor last-id)
   (worker))
  (:menu-bar t)
  (:panes (timeline-pane
           :application
           :incremental-redisplay t
           :display-function 'display-timeline)
          (text-editor
           :text-editor
           :space-requirement (make-space-requirement :width 900))
          (entry-button
           :push-button
           :label "投稿する"
           :activate-callback
           (lambda (button)
             (declare (ignore button))
             (execute-frame-command *application-frame*
                                    `(com-update-status)))))
  (:layouts (default (vertically (:width 900 :height 600)
                       timeline-pane
                       (horizontally (:height 50) text-editor entry-button)))))

(define-twitter-frame-command (com-quit :menu t :name t) ()
  (frame-exit *application-frame*))

(define-twitter-frame-command (com-update-timeline :menu t :name t) ()
  (update-timeline *application-frame*))

(define-twitter-frame-command (com-update-status) ()
  (let* ((text-editor (find-pane-named *application-frame* 'text-editor))
         (new-status (gadget-value text-editor)))
    (update-status new-status)
    (setf (gadget-value text-editor) "")
    (update-timeline *application-frame*)
    (redisplay-frame-panes *application-frame*)))

(defmethod adopt-frame :after (manager (frame twitter-frame))
  (declare (ignore manager))
  (apply #'twitter:authenticate-user *auth*)
  (execute-frame-command frame `(com-update-timeline))
  (setf (slot-value frame 'worker)
        (quek:spawn (loop (quek:receive (:timeout 70)
                            (:quit (return)))
                          (update-timeline frame)
                          (redisplay-frame-panes frame)))))


(defmethod frame-exit :before ((frame twitter-frame))
  (quek:send (slot-value frame 'worker) :quit))

#+nil
(run-frame-top-level (make-application-frame 'twitter-frame
                                             :top 300 :left 600))

clg で twitter クライアントを作ってみた

Common Lisp もいろいろそろってきた。そろそろ GUI かなと思った。 OpenGL でツールキット作れたらいいな。Squeak みたいなのを。と思うのだけど clg を動かしてみる。

例のごとく twitter クライアントを作ってみた。

シグナル（イベント）のハンドラをクロージャで書くから1つの大きな関数ができあがってしまう。こんな作り方でいいのかと思いつつ、Mudballs に負けて cl-smoke を動かせなかった。

clg の雰囲気が多少なりとも分かったので、よしとする。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :gtk)
  (require :cl-twitter)
  (require :net-telent-date))

(gtk:clg-init)

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

(defvar *auth*
  (with-open-file (in (merge-pathnames ".twitter.lisp"
                                       (user-homedir-pathname)))
    (read in)))

(defun dispay-create-at (tweet)
  (multiple-value-bind (second minute hour date month)
      (decode-universal-time
       (net.telent.date:parse-time (twitter:tweet-created-at tweet)))
    (format nil "~02,'0d/~02,'0d ~02,'0d:~02,'0d:~02,'0d"
            month date hour minute second)))

(defun update-timeline (last-id store)
  (let ((new-timeline (twitter:friends-timeline :since-id last-id)))
    (print new-timeline)
    (if new-timeline
        (progn
          (loop with iter = (make-instance 'gtk:tree-iter)
                for i in (reverse new-timeline)
                do (gtk:list-store-append
                       store
                       (list :user (twitter:twitter-user-screen-name
                                    (twitter:tweet-user i))
                             :text (twitter:tweet-text i)
                             :time (dispay-create-at i))
                       iter))
          (twitter:tweet-id (car new-timeline)))
        last-id)))

(defun send-text (text-buffer)
  (let ((text (gtk:text-buffer-text text-buffer)))
    (unless (string= "" text)
      (twitter:send-tweet text)
      (gtk:text-buffer-set-text text-buffer ""))))

(defun main ()
  (apply #'twitter:authenticate-user *auth*)
  (let* ((last-id 1)
         (store (make-instance 'gtk:list-store
                               :column-types '(string string string)
                               :column-names '(:user :text :time)))
         (tree  (make-instance 'gtk:tree-view :model store
                               :expand t :fill t))
         (text-view (make-instance 'gtk:text-view))
         (buffer (gtk:text-view-buffer text-view))
         (scrolled-window (make-instance 'gtk:scrolled-window
                                         :child tree))
         (timer nil))
    (labels ((update ()
               (setf last-id (update-timeline last-id store)))
             (scroll-to-bottom (&rest args)
               (print args)
               (let ((adjustment (gtk:scrolled-window-vadjustment
                                  scrolled-window)))
                 (setf (gtk:adjustment-value adjustment)
                       (- (gtk:adjustment-upper adjustment)
                          (gtk:adjustment-page-size adjustment))))))
      (gtk:signal-connect (gtk:scrolled-window-vadjustment scrolled-window)
                          :changed
                          #'scroll-to-bottom)
      (update)
      (setf timer (gtk:timeout-add 60000 #'update))
      (loop for (title index sizing) in '(("ユーザ" :user :autosize)
                                          ("さえずり" :text :fixed)
                                          ("いつ" :time :autosize))
            do (let ((column (make-instance 'gtk:tree-view-column :title title
                                            :expand (eq :fixed sizing)
                                            :resizable t
                                            :sizing sizing))
                     (cell (make-instance 'gtk:cell-renderer-text)))
                 (gtk:cell-layout-pack column cell :expand nil)
                 (gtk:cell-layout-add-attribute
                  column cell 'text (gtk:tree-model-column-index store index))
                 (gtk:tree-view-append-column tree column)))
      (gtk:within-main-loop
        (make-instance
         'gtk:window
         :default-width  900
         :default-height 700
         :title "clg で twitter"
         :border-width 2
         :visible t :show-children t
         :signal (list :delete-event
                       (lambda (event)
                         (declare (ignore event))
                         (gtk:timeout-remove timer)
                         nil))
         :child (make-instance
                 'gtk:v-box
                 :child (list scrolled-window :expand t :fill t)
                 :child (list
                         (make-instance
                          'gtk:h-box
                          :child (list text-view)
                          :child (list (make-instance
                                        'gtk:button
                                        :label "投稿する"
                                        :signal (list 'clicked
                                                      (lambda ()
                                                        (send-text buffer)
                                                        (update))))
                                       :fill nil :expand nil)
                          :border-width 2)
                         :fill nil :expand nil)))))))

;;(main)

多すぎるキーワードはミニバッファに表示しきれないので

clg で (make-instance 'gtk:window の後に続く引数。あまりにも多すぎてミニバッファに表示しきれない。 eval-when のときみたいに C-c C-s できるかと思ったけどエラーになる。さらに gtk:window の定義に M-. で飛んでみても、マクロで生成してるからどんな引数がとれるかさっぱり分からない。

ということで、ちょっとハック。余計なものもバッファにインサートされるけど、目的は逹っせられる。

(defun my-slime-complete-form ()
  (interactive)
  (condition-case nil
      (slime-complete-form)
    (error
     (save-excursion
       (insert
        (multiple-value-bind (ops arg-indices points)
            (slime-enclosing-form-specs)
          (run-hook-with-args 'slime-autodoc-hook ops arg-indices points)
          (multiple-value-bind (cache-key retrieve-form)
              (slime-compute-autodoc-rpc-form ops arg-indices points)
            (slime-eval retrieve-form))))))))
(add-hook
 'slime-mode-hook
 (lambda ()
   (define-key slime-mode-map "\C-c\C-s" 'my-slime-complete-form)
   (define-key slime-repl-mode-map "\C-c\C-s" 'my-slime-complete-form)
   ...

既にあったりするかな？

パラレルマンデルブロ

risupu - notes on Lisp and programming: Parallel Mandelbrot computation in Lisp on a cluster に触発されて自前の Erlang まねっこライブラリでちょっとやってみた。

(declaim (optimize (speed 3) (safety 0)))

(defconstant +resolution+ 5000)
(defconstant +iterations+ 100)

(declaim (inline iters))

(defun iters (max xc yc)
  (declare (double-float xc yc))
  (let ((x xc)
        (y yc))
    (declare (double-float x y)
             (fixnum max))
    (loop for count from 0 below max
          do (when (>= (+ (* x x) (* y y)) 4.0d0)
               (return-from iters count))
             (let ((tmp (+ (- (* x x) (* y y)) xc)))
               (setf y (+ (* 2.0d0 x y) yc)
                     x tmp)))
    max))

;; http://random-state.net/files/mandelbench.lisp
;; シングルスレッドバージョン
(defun main ()
  (let* ((max (truncate +resolution+ 2))
         (min (- max))
         (mul (/ 2.0d0 max))
         (count 0))
    (declare (fixnum count))
    (loop for i from min upto max
          do (loop for j from min upto max
                   do (incf count (iters +iterations+ (* mul i) (* mul j)))))
    (format t "result ~d~%" count)))


;; 50 スレッドバージョン
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :quek))

(defun pmain ()
  (let* ((max (truncate +resolution+ 2))
         (min (- max))
         (mul (/ 2.0d0 max))
         (count 0)
         (num-procs 50)                 ; 50 スレッド使う
         (rows-pre-proc (/ +resolution+ num-procs))
         (parent quek:*current-thread*))
    (declare (fixnum count))
    (loop for proc from 0 below num-procs do
      (let* ((my-rank proc)
             (local-min (+ min (* my-rank rows-pre-proc)))
             (local-max (1- (+ local-min rows-pre-proc)))
             (local-count 0))
        (declare (fixnum local-min local-max local-count))
        (quek:spawn
          (loop for i from local-min upto local-max do
            (loop for j from min upto max do
              (incf local-count (iters +iterations+ (* mul i) (* mul j)))))
          (quek:send parent local-count))))
    (loop repeat num-procs do
      (quek:receive ()
        (x (locally (declare (fixnum x)) (incf count x)))))
    (format t "result ~d~%" count)))

main の方はオリジナルのコード。 pmain の方は CL-MPI から翻訳。

CL-USER> (time (main))                  ; シングル thread
result 290068052
Evaluation took:
  4.830 seconds of real time
  4.764298 seconds of total run time (4.740296 user, 0.024002 system)
  98.63% CPU
  8,672,484,384 processor cycles
  387,408 bytes consed

NIL
CL-USER> (time (pmain))                 ; 50 thread
result 290068052
Evaluation took:
  2.752 seconds of real time
  5.064316 seconds of total run time (4.872304 user, 0.192012 system)
  184.01% CPU
  4,940,713,287 processor cycles
  302,368 bytes consed

NIL

うん。速くなった。単純に満足する。

ところで CL-MPI の作者は、東京工業大学の先生のもよう。どうりでブログのタイトルが「risupu」だったりするわけだ。

CL-MPI を使えば Common Lisp で分散並列処理が可能になるのかな。いいな。おもしろそうだ。