2009/04/30

ABCL での Java 呼び出し

JVM で動く Common Lisp である Armed Bear Common Lisp (ABCL) の Java 呼び出しはちょっとめんどくさい。クラス名やメソッド名を文字列で指定するのが悲しい。なのでちょっと書いてみたのが下のコード。

Java は大文字小文字の区別があるのでシンボルは縦棒付き。見た感じはタイプするのがめんどくさそうであるが、SLIME が立派なので sDM まで打てば |showMessageDialog| と縦棒付きで補完してくれる。 SLIME えらい。

jcc はチェーンで jcs はカスケード。 yourself はあなた自身ですね。Smalltalk さん。

github に置いておく。いまさらだけど github ってなんかいいね。 fork とか pull request とか。

(eval-when (:compile-toplevel :load-toplevel :execute)
(asdf:oos 'asdf:load-op :cl-ppcre))

(defmacro jimport (fqcn &optional (package *package*))
(let ((fqcn (string fqcn))
(package package))
(ppcre:register-groups-bind (class-name)
(".*\\.(.*)" fqcn)
(let ((class (jclass fqcn)))
`(progn
(defparameter ,(intern fqcn package) ,class)
(defparameter ,(intern class-name package) ,class)
,@(map 'list
(lambda (method)
(let ((symbol (intern (jmethod-name method) package))
(fn (if (jmember-static-p method)
#'jstatic
#'jcall)))
`(progn
(defun ,symbol (&rest args)
(apply ,fn ,(symbol-name symbol) args))
(defparameter ,symbol #',symbol))))
(jclass-methods class)))))))

(defun new (class &rest args)
(apply #'jnew
(apply #'jconstructor class (mapcar #'jclass-of args))
args))


(defmacro jcc (receiver message &rest rest)
(loop for i in rest
with args = nil
if (and (symbolp i)
(typep (symbol-value i) 'function))
do (setf receiver `(,message ,receiver ,@(nreverse args))
message i
args nil)
else
do (push i args)
finally (return `(,message ,receiver ,@(nreverse args)))))

(defmacro jcs (receiver message &rest rest)
(let ((yourself (gensym "yourself")))
`(let ((,yourself ,receiver))
,@(let (result)
(loop for i in rest
with args = nil
if (and (symbolp i)
(typep (symbol-value i) 'function))
do (progn
#1=(push `(,message ,yourself ,@(nreverse args))
result)
(setf message i
args nil))
else
do (push i args)
finally (if (eq i :yourself)
(progn
(push `(,message ,yourself
,@(nreverse (cdr args)))
result)
(push yourself result))
#1#))
(nreverse result)))))
#|
(jimport |java.lang.String|)
(|toUpperCase| "Hello")
(|replaceAll| "Hello" "l" "*ま*")
(jcc "Hello" |toUpperCase| |replaceAll| "L" "*L*")

(jimport |java.lang.Integer|)
(|parseInt| |Integer| "123")

(jimport |java.util.ArrayList|)
(jcs (new |ArrayList|) |add| "a" |add| "b" |toString|)
(|toString| (jcs (new |ArrayList|) |add| "a" |add| "b" |add| "c" :yourself))

(jimport |javax.swing.JOptionPane|)
(|showMessageDialog| |JOptionPane| nil "Hello World! まみむめも♪")
↓は Clojure
(. javax.swing.JOptionPane (showMessageDialog nil "Hello World"))
|#

2009/04/27

やっぱりカメ

昨日もらったカメは「やっぱりカメ返して」と、あっさり強制徴収されてしまった。

2009/04/26

よしビューア作った

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-opengl)
(require :cl-glu)
(require :cl-glut)
(require :cl-jpeg)
(require :drakma))

(defclass jpeg-viewer (glut:window)
((image :initarg :image :initform nil :accessor image))
(:default-initargs :mode '(:rgb :single)))

(defmethod glut:display-window :before ((w jpeg-viewer))
(gl:clear-color 0 0 0 0)
(%gl:shade-model :flat)
(gl:pixel-store :unpack-alignment 1))

(defmethod glut:display ((window jpeg-viewer))
(with-accessors ((image image)
(width glut:width)
(height glut:height)) window
(gl:clear :color-buffer-bit)
(gl:raster-pos 0 0)
(gl:draw-pixels width height :rgb :unsigned-byte image)
(%gl:flush)))

(defmethod glut:reshape ((window jpeg-viewer) w h)
(%gl:viewport 0 0 w h)
(%gl:matrix-mode :projection)
(%gl:load-identity)
(glu:ortho-2d 0 w 0 h)
(%gl:matrix-mode :modelview)
(%gl:load-identity))

(defmethod glut:keyboard ((window jpeg-viewer) key x y)
(declare (ignore x y))
(case key
((#\Esc #\q) (glut:destroy-current-window))))

(defun view (url)
(multiple-value-bind (image height width)
(jpeg:decode-stream (drakma:http-request url :want-stream t))
(loop for h from 0 below (/ height 2)
do (rotatef (subseq image (* h width 3) (* (1+ h) width 3))
(subseq image (- (* height width 3)
(* (1+ h) width 3))
(- (* height width 3)
(* h width 3)))))
(loop for i from 0 below (* height width 3) by 3
do (rotatef (aref image i) (aref image (+ i 2))))
(glut:display-window
(make-instance 'jpeg-viewer
:image image
:width width
:height height))))

;;(view "http://anime.nifty.com/luckystar/images/ls_wp_tpa.jpg")

突然の来訪とつれあいの携帯電話

子供とお風呂にはいっていたら、お義父さんとお義母さんが突然の来訪。私がゴールデンウィーク中に予定されていた合同誕生日会に出席できそうもないということで、誕生日の今日祝いに来てくれた。ありごうございます。

それと、今日はつれあいの携帯電話を買った。初期状態でいろんな有料割引プランが勝手につくのはどうにかならないのかね。いろんなメールも勝手に配信されてくるみたいだし。それらの解約方法の説明を聞くだけでぐったりしてしまった。説明してくれるのはいいけど、どうせならな最初からついてこなければいいのに。

娘からは誕生日プレゼントにカメ(お気に入りのぬいぐるみ)をもらった。本当にくれたのかな?きっと返して、と言われると思う。

イメージ

『OpenGLプログラミングガイド 第2版』はずっととばして第8章へ。イメージを。

glut:reshape のときに glut:width と glut:height が自動的に更新されてほしい気がするだが気のせいだろうか。

(defmethod glut:reshape ((window glut:window) w h)
(setf (glut:width window) w
(glut:height window) h))
というメソッドが定義済であって欲しい。

image.c の cl-opengl バージョン。ひさしぶりに loop ではなく dotimes を使った気がする。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-opengl)
(require :cl-glu)
(require :cl-glut))

(defconstant +width+ 64)
(defconstant +height+ 64)

(defclass image-window (glut:window)
((image :initform (make-array (* +height+ +width+ 3))
:accessor image)
(zoom-factor :initform 1.0
:accessor zoom-factor))
(:default-initargs :mode '(:rgb :single )))

(defmethod make-check-image ((window image-window))
(with-accessors ((image image)) window
(let ((index -1))
(dotimes (i +height+)
(dotimes (j +width+)
(let ((c (* (logxor (if (zerop (logand i #x8)) 1 0)
(if (zerop (logand j #x8)) 1 0))
255)))
(setf (aref image (incf index)) c)
(setf (aref image (incf index)) c)
(setf (aref image (incf index)) c)))))))

(defmethod glut:display-window :before ((w image-window))
(make-check-image w)
(gl:clear-color 0 0 0 0)
(%gl:shade-model :flat)
(gl:pixel-store :unpack-alignment 1))

(defmethod glut:display ((window image-window))
(gl:clear :color-buffer-bit) ; クリア
(gl:raster-pos 0 0)
(gl:draw-pixels +width+ +height+ :rgb :unsigned-byte (image window))
(%gl:flush))

(defmethod glut:reshape ((window image-window) w h)
(setf (glut:width window) w
(glut:height window) h)
(%gl:viewport 0 0 w h)
(%gl:matrix-mode :projection)
(%gl:load-identity)
(glu:ortho-2d 0 w 0 h)
(%gl:matrix-mode :modelview)
(%gl:load-identity))

(defmethod glut:motion ((window image-window) x y)
(with-accessors ((zoom-factor zoom-factor)) window
(let ((screen-y (- (glut:height window) y)))
(print (list (glut:height window) screen-y y))
(gl:raster-pos x screen-y)
(%gl:pixel-zoom zoom-factor zoom-factor)
(%gl:copy-pixels 0 0 +width+ +height+ :color)
(%gl:pixel-zoom 1 1)
(%gl:flush))))

(defmethod glut:keyboard ((window image-window) key x y)
(declare (ignore x y))
(with-accessors ((zoom-factor zoom-factor)) window
(case key
((#\r #\R)
(setf zoom-factor 1)
(glut:post-redisplay))
(#\z
(when (<= 3 (incf zoom-factor 0.5))
(setf zoom-factor 3)))
(#\Z
(when (<= (decf zoom-factor 0.5) 0.5)
(setf zoom-factor 0.5)))
((#\Esc #\q) (glut:destroy-current-window)))))

;;(glut:display-window (make-instance 'image-window))

2009/04/21

光源の移動

もちろん光源も移動するよね。移動の方法はモデルと同じなんだね。

緑色の光にしてみた。

『OpenGLプログラミングガイド 第2版』の movelight.c を cl-opengl で。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-opengl)
(require :cl-glu)
(require :cl-glut))

(defclass move-light-window (glut:window)
((spin :initform 0))
(:default-initargs :title "Move Light"
:mode '(:single :rgb :depth)
:width 500 :height 500 :pos-x 300 :pos-y 300))

(defmethod glut:keyboard ((window move-light-window) key x y)
(declare (ignore x y))
(case key
(#\q (glut:destroy-current-window))))

(defmethod glut:display-window :before ((window move-light-window))
(gl:clear-color 0 0 0 0)
(%gl:shade-model :smooth)
(gl:enable :lighting :light0 :depth-test))

(defmethod glut:display ((window move-light-window))
(gl:clear :color-buffer-bit :depth-buffer-bit)
(gl:with-pushed-matrix
(glu:look-at 0 0 5
0 0 0
0 1 0)
(gl:with-pushed-matrix
(%gl:rotate-d (slot-value window 'spin) 1 0 0) ; x を軸に回転
(gl:light :light0 :position '(0 0 1.5 1))
(gl:light :light0 :diffuse '(0 1 0 1)) ; 緑色の光
(%gl:translate-d 0 0 1.5)
(gl:disable :lighting) ; wire-cube のとき光は関係ない
(gl:color 0 1 1)
(glut:wire-cube 0.1)
(gl:enable :lighting)) ; solid-torus のとき光が関係する
(glut:solid-torus 0.275 0.85 8 15))
(%gl:flush))

(defmethod glut:reshape ((window move-light-window) w h)
(%gl:viewport 0 0 w h)
(%gl:matrix-mode :projection)
(%gl:load-identity)
(glu:perspective 40 (/ w h) 1 20)
(%gl:matrix-mode :modelview)
(%gl:load-identity))

(defmethod glut:mouse ((window move-light-window) button state x y)
(with-slots (spin) window
(case button
(:left-button
(when (eq state :down)
(setf spin (mod (+ spin 30) 360)) ; 左クリックする度に30度光を移動する。
(glut:post-redisplay))))))

;;(glut:display-window (make-instance 'move-light-window))

2009/04/19

立体っぽくなった

ようやく照光処理まできた。『OpenGLプログラミングガイド 第2版』の第5章だ。

cl-opengl は作りがいいように感じる。素直に OpengGL の関数が使えるし、ちょっと面倒なところはちゃんとラッパーが用意されてる。今回の gl:material とか。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-opengl)
(require :cl-glu)
(require :cl-glut))

(defclass light-window (glut:window)
()
(:default-initargs :title "Light"
:mode '(:single :rgb :depth)
:width 500 :height 500 :pos-x 300 :pos-y 300))

(defmethod glut:keyboard ((window light-window) key x y)
(declare (ignore x y))
(case key
(#\q (glut:destroy-current-window))))

(defmethod glut:display-window :before ((window light-window))
(gl:clear-color 0 0 0 0)
(%gl:shade-model :smooth)

(gl:material :front :specular '(1 1 1 1))
(gl:material :front :shininess 50)
(gl:light :light0 :position '(1 1 1 0))

(gl:enable :lighting :light0 :depth-test))

(defmethod glut:display ((window light-window))
(gl:clear :color-buffer-bit :depth-buffer-bit)
(glut:solid-sphere 1 200 160)
(%gl:flush))

(defmethod glut:reshape ((window light-window) w h)
(%gl:viewport 0 0 w h)
(%gl:matrix-mode :projection)
(%gl:load-identity)
(if (<= w h)
(%gl:ortho -1.5 1.5 (* -1.5 (/ h w))
(* 1.5 (/ h w)) -10 10)
(%gl:ortho (* -1.5 (/ w h)) (* 1.5 (/ w h)) -1.5
1.5 -10 10))
(%gl:matrix-mode :modelview)
(%gl:load-identity))

;;(glut:display-window (make-instance 'light-window))