PythonのImageモジュールを使う

この間Python Imaging Libraryを使ったが、画像データをRGBのリストにする方法を調べるだけでけっこう時間がかかってしまったのでメモっておく。利用しているPythonは2.5.2。

プログラムの内容は自分でもよくわかってないけど、画像をNxNに分割して、分割した領域の色の平均を取ってるのだと思われるが、正しいんだろうか。

HSVとかXYZとか色空間ってなんなんだろう。ライブラリ+人に言われたアルゴリズムで適当に変換したけど。

本題のImageモジュールの使い方としては、

• Image.open(path)でファイルを開きオブジェクトを作る
• オブジェクトのサイズ(obj.size)は(width, height)
• オブジェクトのモード(obj.mode)はconvertメソッドで変更できる
• getdataメソッドでピクセルのリストを取得できる。この状態ではPILで使うデータ型なので、一般的なリストが欲しければlist(obj.getdata())とする

という流れだった。 getdataメソッドくらいしか利用していないけど、他にもいろいろ出来るようだ。

import Image;
import sys;
import math;
import colorsys;

nsplit = 10

def HSVtoXYZ(h,s,v):
    return s*v*math.cos(h), s*v*math.sin(h), v

def RGBtoXYZ(r,g,b):
    return apply(HSVtoXYZ, colorsys.rgb_to_hsv(r/255.0,g/255.0,b/255.0))

def ColorBlockAverage(seq, x, y, xSize, ySize, width):
    r,g,b = 0,0,0
    for ytmp in range(0,ySize):
        for xtmp in range(0,xSize):
            rgb = seq[(y+ytmp)*width + (x+xtmp)]
            r += rgb[0]
            g += rgb[1]
            b += rgb[2]
    return RGBtoXYZ(r/(xSize*ySize), g/(xSize*ySize), b/(xSize*ySize))

def ColorAverages(seq, n, width, height):
    xSize = width/n
    ySize = height/n
    result = []
    for y in range(0,n):
        for x in range(0,n):
            result.append(ColorBlockAverage(seq,x*xSize,y*ySize,xSize,ySize,width))
    return result

argvs = sys.argv
argc = len(argvs)
if (argc < 2):
    print "Required 1 argument"
    quit()

try:
    img = Image.open(argvs[1])
#    print img.format, img.size, img.mode

    width, height = img.size

    if img.mode == "RGB" :
#        print "RGB image"
        ""
    else:
#        print "Image file is not RGB mode. Convert to RGB mode"
        img.convert("RGB")

#    R,G,B = 0,1,2
    seq = list(img.getdata())
    result = ColorAverages(seq, nsplit, width, height)

    for xyz in result:
        print xyz[0],xyz[1],xyz[2],
    print ""

except IOError:
    print "IOError"

ひどいコードを書いている自身はあるが、Pythonはろくに触ったことないし・・・という言い訳で逃げることにする。

ライブラリのパワーでなんとかしてもらえるのがPythonの素晴らしいところですね。

CommonLispで決定性有限オートマトン(DFA)

オートマトンの書籍を読んでいるので、CommonLispでDFAを定義してみる。

とりあえず目標として、記号列が(c c)で終わるものを受理するようなDFAを目指す。

(defmacro define-dfa (name (&rest ends) &body defs)
  `(let ((table ',defs))
     (defmethod accept-p ((type (eql ',name)) sym)
       (find sym ',ends))
     (defmethod next-state ((type (eql ',name)) input crr)
       (let ((al (cdr (assoc crr table))))
	 (and al
	      (second (assoc input al)))))
     (defmethod run ((type (eql ',name)) syms begin)
       (let ((last begin))
	 (loop
	    :for sym in syms
	    :for state = last
	    :do (setf last (next-state type sym state))
	    :unless last
	    :do (return-from run :reject))
	 (if (accept-p type last)
	     :accept :reject)))))

正直ただしいのかわからない。

以下、DFAの定義。

(define-dfa cc (:end)
  (:0
   (a :0)
   (b :0)
   (c :1))
  (:1
   (a :0)
   (b :0)
   (c :end))
  (:end
   (a :0)
   (b :0)
   (c :end)))

存在する記号はa,b,cの3種類。記号列はリスト形式で受け取る。現在の状態と入力の組に対して、次の状態が存在しなければそこで処理を終了する。リスト内の要素すべてを処理したら、最終的な状態が受理状態であるかを調べる。

以下、実行例。

>(run 'cc '(c) :0)
:REJECT
>(run 'cc '(c c) :0)
:ACCEPT
>(run 'cc '(a b c) :0)
:REJECT
>(run 'cc '(a b c c) :0)
:ACCEPT
>(run 'cc '(a b c c c c) :0)
:ACCEPT
>(run 'cc '(a b c c a) :0)
:REJECT

ぱっと見た感じではうまく動いているような気がする。気のせいかもしれないけれど。

SBCLでバイト列を逆アセンブルする

Kernel/VM探検隊に参加しました。皆さんスペック高すぎです。参加したおかげで上がったテンションのまま、SBCLで遊んでみた。

1.SBCLにはネイティブコードコンパイラが備わっている。

2.CommonLispでは仕様でdisassemble関数が定義されている。

つまり、SBCLでバイト列を逆アセンブルことは簡単。たぶん。

ということでやってみた。

(defun disassemble-u8-list (u8-list)
  (let ((len (length u8-list)))
    (let ((alien (sb-alien:make-alien sb-alien:unsigned-char len)))
      (unwind-protect
    (progn
      (loop :for i from 0
  :for u in u8-list
  :do (setf (sb-alien:deref alien i) u))
      (sb-disassem:disassemble-memory (sb-alien:alien-sap alien) len))
 (sb-alien:free-alien alien)))))

準備として、アセンブラで適当にコードを書く。

bits 32
section .text

global _start
_start:
 mov eax, 4  ;write
 mov ebx, 1  ;fd
 mov ecx, ptr  ;buf
 mov edx, 6  ;size
 int 0x80
 mov eax, 1  ;exit
 mov ebx, 0
 int 0x80
ptr db 'Hello',10

>nasm -f elf32 test.asm
>ld -o test test.o
>./test
Hello
>nasm -f bin -o test.bin test.asm
>hd test.bin
00000000  b8 04 00 00 00 bb 01 00  00 00 b9 22 00 00 00 ba  |..........."....|
00000010  06 00 00 00 cd 80 b8 01  00 00 00 bb 00 00 00 00  |................|
00000020  cd 80 48 65 6c 6c 6f 0a                           |..Hello.|
00000028

このバイト列を逆アセンブルしてみる。

>(disassemble-u8-list
  '(#xb8 #x04 #x00 #x00 #x00 #xbb #x01 #x00 #x00 #x00
    #xb9 #x22 #x00 #x00 #x00 #xba #x06 #x00 #x00 #x00
    #xcd #x80 #xb8 #x01 #x00 #x00 #x00 #xbb #x00 #x00
    #x00 #x00 #xcd #x80 #x48 #x65 #x6c #x6c #x6f #x0a))
; 08089CA8:       B804000000       MOV EAX, 4
;       AD:       BB01000000       MOV EBX, 1
;       B2:       B922000000       MOV ECX, 34
;       B7:       BA06000000       MOV EDX, 6
;       BC:       CD80             INT 128
;       BE:       B801000000       MOV EAX, 1
;       C3:       BB00000000       MOV EBX, 0
;       C8:       CD80             INT 128
;       CA:       48               DEC EAX
;       CB:       65               GS-SEGMENT-PREFIX
;       CC:       6C               INSB
;       CD:       6C               INSB
;       CE:       6F               OUTSD
;       CF:       0A00             OR AL, [EAX]
NIL

２回目のINT命令以降は文字列。objdumpの結果とくらべても間違いはなさそう。最後の0x0Aが0A00とされているが、メモリ上の次の値を読んでいそう。

本日の酒(2010/02/22)

• 真桜 純米吟醸 (福島/大七酒造株式会社)

Nachosを学ぶ

概要

Nachos(Not Another Completely Heuristic Operating System)はカリフォルニア大学バークレー校で開発された教育用のオペレーティングシステム。

C++で記述されていて、MIPSやx86上のlinuxやSolarisなどで動く・・・んだと思う。

Nachos自体はユーザーレベルで動作し、Nachosのユーザープログラムは MIPSシミュレーターで動作する。

MIPSシミュレーターはディレクトリmachine以下でMachineクラスとして実装されている。userprog/exception.ccあたりも利用しているので machineディレクトリ以外も気をつけなければならないところがあるかも。

クラス一覧

ヘッダファイルからなんとなく読み取ったこと。

• filesysディレクトリ
  • DirectoryEntry (ディレクトリエントリ。ディレクトリ中のファイルを表現する。ファイル名とヘッダのディスク中の位置を保持する(sector))
  • Directory (UNIX-likeのディレクトリ)
  • FileHeader (ファイルヘッダ(UNIXでいうならi-node)ファイル本体がディスク中のどこにあるかといった情報を持つ)
  • FileSystem (2つのうちどちらか。STUBはUNIX関数をラップしたもので,realはディスクの処理をシミュレートする)
  • OpenFile (FileSystemに合わせて2つある。個々のファイルのread,write,closeなどを扱う)
  • SynchDisk (スレッドからのリクエストに対してディスク操作し、割り込みをかけて通知するようにみせる)
• machineディレクトリ
  • Console (コンソールデバイス)
  • Disk (ディスクIOデバイス。セクタ番号でアドレッシング。UNIXファイルをディスクに見立てる)
  • PendingInterrupt (将来発生するのでスケジューリングされる割り込み)
  • Interrupt (ハードウェア割り込みをシミュレートする)
  • Instruction (MIPSプログラムを読み込んだ個々の命令。opCodeはMIPSのopcodeフィールドとは異なる)
  • Machine (シミュレーター)
  • PacketHeader (ネットワークパケットのヘッダ)
  • Network (ネットワークデバイス。固定長のパケットを転送できる。)
  • Statistics (statistics=統計。Nachosの振舞についての統計情報。時間、ディスクIOなど。)
  • Timer (ハードウェアタイマー)
  • TranslationEntry (変換テーブルのエントリ。ページテーブルかTLB(Translation Lookaside Buffer)。どちらも仮想->物理アドレス変換)
• networkディレクトリ
  • MailHeader (Mailのヘッダ)
  • Mail (Mailメッセージ)
  • MailBox (メールボックス)
  • PostOffice (メールボックスへのメッセージの送信と受信を扱う)
• threadsディレクトリ
  • ListElement (単方向リスト。ソートされたリストを利用する場合のためのkeyとvoid* itemを持つ)
  • List (単方向リスト。ListElementを管理する。firstとlastへのポインタを保持)
  • Scheduler (スケジューラ/ディスパッチャ。現在動作しているスレッドと動作可能なスレッドを保持する)
  • Semaphore (セマフォ。Pメソッド(down)とVメソッド(up)がある。)
  • Lock (ロック。BUSYかFREE状態をとる。Acquire(手に入れる),Releaseメソッドがある。必要なら要素を付け足してね、と書いてある。)
  • Condition (condition variable。値を持たない。Wait,Signal,Broadcastメソッドがある。Mesa-styleってなんだろう。)
  • SynchList (synchronized list.Removeするとき空なら要素が追加される間で待つ。同時にアクセスできるのは1スレッドだけ)
  • Thread ("thread control block"を定義。stack(bottom),stackTop,status,machineState(レジスタの状態)などをメンバとして持つ)
• userprogディレクトリ
  • AddrSpace (ユーザプログラムの実行に関する情報を持つが、いまはthreadがCPU状態等を保存してる?)
  • BitMap (ビット列。セット、クリア、テストができる)

Machineクラスメモ

Machineで利用されるOP_xxxという定数は、MIPSのオペコードそのものではなく、変換テーブルを使って変換した後の定数値。

システムコールは例外を発生させることで処理されるが、Halt以外の処理は実装されていない。

Machine::OneInstruction内でMIPS用バイナリコードの読み込み、Machineで利用する内部構造(Instructionクラス)への変換(Decodeメソッド)を行ったのち、命令ごとに処理を行うが、OP_SYSCALLであった場合はMachine::RaiseExceptionが呼び出され、そこから exception.ccのExceptionHandlerが呼び出される。

threadsディレクトリを読む

Nachosのエントリポイントはthreads/main.ccのmain関数。 OSとしての処理の中心はthreadsディレクトリ内のファイルで実装されているようなので、このあたりから見ていく。

mainではInitialize関数でグローバルなデータ構造の初期化(currentThread = new Thread("main")なども)する。コマンドラインオプションに応じたテストの類も行う。

return(0)とあるが、その前のcurrentThread->Finish()時に他のスレッドが無ければ最終的に Cleanup関数を呼び出してその中のExit(0)で終了する。

Threadクラス

int* stackTopとint machineState[MachineStateSize]メンバは場所を変えるなと書かれている。

あと、スタックの容量にも気をつける。

Threadクラスのpublicメソッド

コンストラクタはデバッグ用の名前を引数にとり、nameに設定する。statusをJUST_CREATEDにする以外は、NULLに設定する。

デストラクタはスレッドの解放を行うが、this == currentThreadの場合はスタックの解放が行えないため不正である。スタックの解放にはDeallocBoundedArray関数を用いる。

Forkメソッドは引数にとった関数をスレッドで走らせる。 callerとcalleeが同時に動作実行される事を許す。 StackAllocateメソッドの呼び出しスタックの確保と初期設定を行った後で scheduler->ReadyToRun(this)でスケジューラーに登録する。

Yieldメソッドは他に実行可能なスレッドがあれば、CPUを放棄させる。その場合はscheduler->ReadyToRunメソッドで実行可能プロセスのリストにCPUを放棄したスレッドを追加する。

Sleepメソッドはスレッドを眠らせ、CPUを放棄させる。 Yieldと異なり、スレッドはブロック状態になるので実行可能リストには追加されない。他に実行可能スレッドが無い場合はInterrupt::Idleメソッドを呼び出し続ける。

Finishメソッドはスレッドの実行を終了する。 ThreadRootから処理終了時に呼ばれる。まだ実行中なので、即座にスタックの解放等を行うわけではなく、 threadToBeDestroyedにスレッドをセットしSleepする。実際にスレッドが解放されるのは次回のscheduler->Run()中である。

CheckOverflowメソッドはスタックがオーバーフローしているか確認する。 int* stackの値がStackAllocateメソッドでセットしたSTACK_FENCEPOSTか確認することでオーバーフローが起きたかどうかをチェックする。

setStatusメソッドはスレッドの状態を設定する。

getNameメソッドはデバッグ用のスレッドの名前(コンストラクタで設定)を返す。

Printメソッドはスレッドの名前を表示する。

SaveUserStateメソッドはユーザプログラムを動作させているmachineのレジスタを保存する。 userRegisters[i] = machine->ReadRegister(i)

RestoreUserStateメソッドはユーザプログラムを動作させているmachineのレジスタを復元する。 machine->WriteRegister(i, userRegisters[i])

Threadクラスメンバ変数

変数名	説明
AddrSpace* space	ユーザーコード
int* stackTop	スタックポインタ(スタックトップ)
int machineState[MachineStateSize]	stackTop以外のレジスタ
int* stack	スタックの底.mainスレッド(Initializeで作られるスレッドか)はNULL。
ThreadStatus status	スレッドの状態。ready,running,blocked,just_created
char* name	デバッグ用の名前
int userRegisters[NumTotalRegs]	user-level CPU register state(カーネルコード実行中とユーザコード実行中は別に保存するため)

Threadクラスprivateメソッド

StackAllocateメソッドはForkメソッド内部で使われ、スタックの確保と初期設定を行う。スタックはAllocBoundedArray関数によって確保される。 AllocBoundedArrayはスタックの前後に1ページサイズ(getpagesizeの返り値)ずつ余分に領域を確保する。 i386ではstackTop = stack + StackSize - 4とされているが、-4は大事をとってるだけらしい。スタックにはSWITCH()でThreadRootを呼び出すための値を積んでいる。 machineStateに呼び出す関数やその引数などを設定する。

ThreadRootはアセンブラルーチン。 StartupPc,InitialPc,WhenDonePcレジスタの指す関数を順に実行する。WhenDonePCでthread->Finish()が呼び出されるはずなので、そのあとに処理は続かない。 i386ではInitialPCはESI,InitialArgはEDX,WhenDonePCはEDI,StartupPCはECXである。 ThreadRootが呼び出された時点でこれらのレジスタにはStackAllocateで設定した値がセットされている。おそらくSWITCHでスレッド先頭のmachineStateから読み込まれるのだろう。

例えばmachineState[InitialPC]はESI(%thread)というイメージ。switch.hでの定義の-1はint* stackTopの分(4バイト)の差だろう。

thread先頭からESI=24, EDX=16, EDI=28, ECX=12.

Schedulerクラス

スケジューラー。スレッドの切り替えはswitch.sのSWITCH手続きで行う。

Schedulerクラスpublicメソッド

コンストラクタはreadyListを初期化する。

デストラクタはreadyListを解放する。

ReadyToRunメソッドはスレッドを実行可能状態にし、実行可能スレッドのリストに追加する。 thread->setStatusでREADYをセットし、readyList->Append(thread)で最後尾にスレッドを追加する(エンキュー)。

FindNextToRunメソッドは次に実行すべきスレッドを返す。実行可能なスレッドが無ければNULLを返す。 readyList->Remove()の返り値を返している(デキュー)。

Runメソッドは引数に指定したスレッドを操作させる。切り替わる前のスレッドの状態はRunメソッドが呼び出される前にBLOCKEDかREADYになっているものとみなす。 currentThreadが変更されるのはこのメソッドの内部である。また、threadToBeDestroyedがセットされていればスレッドの切り替え後にそのスレッドを解放する。

PrintメソッドはreadyListの内容を表示する。

Schedulerクラスの変数

名前	説明
List* readyList	実行中で無いが実行可能なスレッドを保持するリスト。キューとして扱う。

SWITCH手続き

void SWITCH(Thread* oldThread, Thread* newThread)となっている。コンテキストスイッチを行うアセンブラルーチンで、CPUに依存する。

どうもswitch.sのうち必要な分だけ抜き出されてswtch.sになってる・・・っぽい。 ThreadRoot手続きもswtch.s(switch.s)にある。

EAXに引数の値(スレッドへのポインタ)をセットして使うので、EAX自体の値は_eax_saveという領域に一時保存して保存、復元する。リターンアドレスを4(%esp)にセットするのはなぜだろう。0(%esp)がSWITCHからのリターンアドレスだと思うのだが。

Semaphoreクラス

Semaphoreクラスpublicメソッド

コンストラクタはセマフォの値の初期値を引数にとる。キューの初期化をする。

デストラクタはキューを解放する。

Pメソッドはdown操作である。 value==0ならばスレッドをスリープする。 valueを1減少させる。

Vメソッドはup操作である。セマフォを待っているスレッドがあれば1つ起こす。 valueを1増加させる。

Semaphoreクラス変数

変数名	説明
List* queue	P(down)でスリープしているスレッドを保持するキュー
char* name	デバッグ用の名前
int value	セマフォの値。常に0以上

Lockクラス

実装が不完全

Conditionクラス

実装が不完全。

cl-dotでお絵描き

cl-dotはGraphvizというツール群を使ってグラフを書くためのCommonLispライブラリ。日本語は出力できないらしい。

デバイスの階層っぽい図を書いてみた。クラス階層なんかも同じ要領で書けそう。

(asdf:oos 'asdf:load-op :cl-dot)

;;;デバイスの階層を表現
(defparameter *resources*
  `("Device"
    ("CharacterDevice"
     ("Keyboard")
     ("Mouse"))
    ("BlockDevice"
     ("HardDisk")
     ("FloppyDisk"))))

(defmethod cl-dot:graph-object-node ((graph (eql 'resources)) (object list))
  (make-instance 'cl-dot:node
		 :attributes
		 (list :label (first object)
		       :shape :box
		       :fontname "Arial"
		       ;; :style :filled
		       ;; :fillcolor "#ffffff"
		       :color :black)))

(defmethod cl-dot:graph-object-points-to ((graph (eql 'resources)) (object list))
  (cdr object))

(defun run (path &key (format :png))
  (let ((graph
	 (cl-dot:generate-graph-from-roots 'resources (list *resources*))))
    (cl-dot:dot-graph graph path :format format)))

;;(run "test.png")

cl-gdでお絵描き

Common LispでGD Graphics libraryを利用するためのライブラリ、cl-gdを使って遊んでみる。

asdf-installでインストールできるが、利用するためには cl-gdのディレクトリにあるcl-gd-glue.cからcl-gd-glue.soを作る必要がある。 Makefileがあるが、libiconvがいらないっぽいのでそこだけ修正してmakeする。

絵心はないので、図形を書いてみた。

以下はシェルピンスキーの三角形(?)を書くコード。

(defun draw-sierpinski-triangle (n size path)
  (when (< n 1) (error "Required 'n >= 1'"))
  (cl-gd:with-image* (size size)
    ;;background(white)
    (cl-gd:allocate-color 255 255 255)
    (let ((black (cl-gd:allocate-color 0 0 0))
	  (white (cl-gd:allocate-color 255 255 255)))
      (draw-triangle (round size 2) 0 size black)
      (when (> n 1)
	(labels ((inner (n x y size)
		   (draw-triangle x (+ size y) (round size 2) black t)
		   (when (> n 2)
		     (let ((half (/ size 2)))
		       (inner (1- n) x y half)
		       (inner (1- n) (- x (round size 4)) (+ y half) half)
		       (inner (1- n) (+ x (round size 4)) (+ y half) half)))))
	  (inner n (/ size 2) 0 size))))
    (cl-gd:write-image-to-file path :if-exists :supersede)))

(defun draw-triangle (x y size color &optional (reverse? nil))
  (let ((half (round size 2))
	(x (round x))
	(y (round y))
	(size (round size)))
    (cl-gd:draw-polygon
     (if reverse?
	 (list x y (- x half) (- y size) (+ x half) (- y size))
	 (list x y (- x half) (+ y size) (+ x half) (+ y size)))
     :color color)))

;;(draw-sierpinski-triangle 5 300 "hoge.jpg")

SBCL1.0.35のlispobj

SBCLのsrc/runtimeディレクトリのC言語で記述された箇所を読む努力をしてみる。脳みそのスペックと英語力と注意力が無いので多々憶測を含む。

lispobjは名前のとおりlispのオブジェクトを表すものだと思われるが、こいつがどのように利用されているか見ていく。

N_WORD_BITS == 32とする(genesis/config.h)。 runtime.hやgenesis/constants.hあたりにタグなどの定義がある。

定義(runtime.h)

/* fake it on alpha32 */
typedef unsigned int lispobj;
#define LOW_WORD(c) ((long)(c) & 0xFFFFFFFFL)

LOWTAG

LOWTAG_MASKはconstants.h(自動生成される)で7と定義されている。 lispobjの下位3ビットを利用したタグ。

• タグの値：定義されている定数の名前
• 0:EVEN_FIXNUM_LOWTAG
• 1:INSTANCE_POINTER_LOWTAG
• 2:OTHER_IMMEDIATE_0_LOWTAG
• 3:LIST_POINTER_LOWTAG
• 4:ODD_FIXNUM_LOWTAG
• 5:FUN_POINTER_LOWTAG
• 6:OTHER_IMMEDIATE_1_LOWTAG
• 7:OTHER_POINTER_LOWTAG

ビット0が立っていれば何らかのポインタである。

整数をN_FIXNUM_TAG_BITS(2)左にシフトすることで偶数ならEVEN_FIXNUM_LOWTAGが、奇数ならODD_FIXNUM_LOWTAGがLOWTAGにセットされる。なのでfixnumが表現できるのは29ビット30ビット。 OTHER_IMMEDIATE_x_LOWTAGはWIDETAGで何を示すのかを表すっぽい。

WIDETAG

WIDETAG_MASKが255と定義されているので、lispobjの下位8ビットがWIDETAG。 xxx_WIDETAGと定義されている定数の下位3ビットが2か6になっているので、LOWTAGが OTHER_IMMEDIATE_x_LOWTAGのときはWIDETAGで値の種類を判別するのだと思う。

メモ

lispobjとはとくに関係ないけど、runtime.hのQSHOW_SIGNALSを真にすると実行中にいろいろメッセージを吐くようになる。 make.shを実行すると、runtimeディレクトリにsbclという実行ファイルが作られる。 --core引数をつけずに実行すると、search_for_core関数でコアファイルを探そうとする。 コアファイルはcoreparse.cのload_core_file関数で読み込まれるが、その際コアファイルと実行ファイルのビルドIDが一致しなければnever_returns [ __attribute__((noreturn))]であるlose関数を呼び出す。

loseはわりといろんなところから呼ばれている。処理を続行できないエラーの場合に呼び出しているのだろう。

load_core_fileは最初に実行すべき関数のlispobjを返す。このlispobjを main関数の終わり付近でcreate_initial_thread関数の引数として利用する。

日本酒購入(2010/02/06)

今日は。鶴見の総持寺を見に行った。帰りがけに鶴見駅前の酒屋「和泉屋」で日本酒を購入した。

• 加賀鳶 極寒純米　無濾過・生 (石川[金沢]/福光屋)

さっそく飲むかと思いきや、先に前に買っておいた名誉冠大吟醸(京都/山本本家)を飲むことにした。

McCLIMでライフゲーム

McCLIMでライフゲームをやってみた。描画が遅いのでどうしようかと調べてみたところ、 with-output-bufferedとclimi::with-double-buffering というそれっぽいのが見つかった。

with-double-bufferingはエクスポートされていないので、とりあえずは wiht-output-bufferedを使った。

(require :asdf)
(asdf:oos 'asdf:load-op :mcclim)
(asdf:oos 'asdf:load-op :portable-threads)

(in-package :clim-user)
(defparameter +block-size+ 10)
(defparameter +field-size-x+ 10)
(defparameter +field-size-y+ 10)

(defun draw (frame stream)
  (let ((f (field frame))
	(medium (sheet-medium stream)))
    (clim:with-output-buffered (medium)
;;    (climi::with-double-buffering ((stream 0 0 500 500) (wtf))
      (dotimes (i (array-dimension f 0))
	(dotimes (j (array-dimension f 1))
	(draw-rectangle* medium
;;      (draw-rectangle* stream
			 (* i +block-size+) (* j +block-size+)
			 (* (1+ i) +block-size+) (* (1+ j) +block-size+)
			 :ink (if (= 1 (aref f i j)) +black+ +white+)))))
    (medium-finish-output medium)
    (clim:medium-force-output medium)
  ))

(defun update-field (field tmp)
  (let ((x-limit (array-dimension tmp 0))
	(y-limit (array-dimension tmp 1)))
    (dotimes (i x-limit)
      (dotimes (j y-limit)
	(setf (aref tmp i j)
	      (next field i j x-limit y-limit)))))
  tmp)

(defun next (field x y x-limit y-limit)
  (case (- (loop
	      :for i
	      from (if (= x 0) 0 -1)
	      to (if (= x (1- x-limit)) 0 1)
	      :sum (loop
		      :for j from (if (= y 0) 0 -1)
		      to (if (= y (1- y-limit)) 0 1)
		      :sum (aref field (+ x i) (+ y j))))
	   (aref field x y) 1 0)
    ((3) 1)
    ((2) (if (aref field x y) 1 0))
    (T 0)))

(define-application-frame lifegame-frame ()
  ((field :accessor field :initform nil)
   (tmp-field :accessor tmp-field :initform nil)
   (timer-process :accessor timer-process :initform nil))
  (:menu-bar t)
  (:panes
   (canvas :application
	   :min-width 200
	   :min-height 200
	   :scroll-bars T
	   :display-time :command-loop
	   :display-function 'draw))
  (:layouts
   (default (horizontally () canvas))))

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

(define-lifegame-frame-command (com-update :menu t) ()
  (setf (tmp-field *application-frame*)
	(update-field (field *application-frame*)
		      (tmp-field *application-frame*)))
  (rotatef (tmp-field *application-frame*)
	   (field *application-frame*))
  (redisplay-frame-panes *application-frame*))

(defun init-field (field x y)
  (dotimes (i x)
    (dotimes (j y)
      (setf (aref field i j)
	    (if (< (random 10) 7)
		0 1))))
  field)

(defclass timer-event (device-event)
  ()
  (:default-initargs :modifier-state 0))

(defmethod handle-event ((client application-pane) (event timer-event))
  (com-update))

(defmethod run-frame-top-level ((frame lifegame-frame) &key)
  (let ((tls (frame-top-level-sheet frame))
	(canvas (get-frame-pane frame 'canvas)))
    (format t "spawn-thread~%")
    (setf (timer-process frame)
	  (portable-threads:spawn-thread
	   "timer"
	   #'(lambda ()
	       (loop
		  :do
		  (sleep 1.0)
		  (queue-event tls (make-instance 'timer-event :sheet canvas))
		  ))))
    (call-next-method)
    (format t "return from call-next-method~%")
    (when (timer-process frame)
      (portable-threads:kill-thread (timer-process frame)))))

(defun run (&optional (x +field-size-x+) (y +field-size-x+))
  (let ((f (make-array (list x y) :initial-element 0))
	(tmp (make-array (list x y) :initial-element 0))
	(frame (make-application-frame 'lifegame-frame)))
    (init-field f x y)
    (setf (field frame) f)
    (setf (tmp-field frame) tmp)
    (run-frame-top-level frame)))

;;(run 60 50)

McCLIMで時計っぽいもの

Common LispのGUIライブラリといえばMcCLIMがある。日本語資料の少なさとか他のGUIライブラリとの差異とかはご愛嬌というやつでしょう。

このMcCLIM、ユーザインターフェースを作るときは良いけれど、一定時間ごとに再描画したい、というようなユーザの動作が絡まないときの処理をどう書けば良いかよくわからない。

一定時間ごとにイベントを発生させられれば良いのだけど、よくわからないので他にスレッドを作ってそちらに任せることで解決しようとしてみた。

(require :asdf)
(asdf:oos 'asdf:load-op :mcclim)
(asdf:oos 'asdf:load-op :portable-threads)

(in-package :clim-user)

(defun draw (frame stream)
  (declare (ignore frame))
  (multiple-value-bind
	(sec min hour) (get-decoded-time)
    (let ((sec-rad (* 2 pi (/ (- (* sec 6)90) 360)))
	  (min-rad (* 2 pi (/ (- (* min 6)90) 360)))
	  (hour-rad (* 2 pi
		       (/ (- (+ (* hour 30) (/ min 2)) 90)
			  360))))
      (format stream "~{~a~^:~}" (list hour min sec))
    (draw-line* stream 100 100
		 (+ 100 (* 30 (cos sec-rad)))
		 (+ 100 (* 30 (sin sec-rad)))
		 :ink (make-rgb-color 0.0 1.0 0.0))
    (draw-arrow* stream 100 100
		 (+ 100 (* 30 (cos min-rad)))
		 (+ 100 (* 30 (sin min-rad)))
		 :ink (make-rgb-color 0.0 0.0 1.0))
    (draw-arrow* stream 100 100
		 (+ 100 (* 20 (cos hour-rad)))
		 (+ 100 (* 20 (sin hour-rad)))
		 :ink (make-rgb-color 0.0 0.0 1.0))
    (draw-circle* stream 100 100 30
		  :filled nil
		  :ink (make-rgb-color 1.0 0.0 0.0)))))

(define-application-frame clock-frame ()
  ((clock-process :accessor clock-process :initform nil)) ;slots
  (:menu-bar t)
  (:panes
   (canvas :application
	   :min-width 200
	   :min-height 200
	   :scroll-bars nil
	   :display-time :command-loop
	   :display-function 'draw))
  (:layouts
   (default (horizontally () canvas))))

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

(defclass redraw-clock-event (device-event)
  ()
  (:default-initargs :modifier-state 0))

(defmethod handle-event ((client application-pane) (event redraw-clock-event))
  (format t "handle-event(redraw)~%")
  (with-application-frame (frame)
    (redisplay-frame-pane frame client)))

(defmethod run-frame-top-level ((frame clock-frame) &key)
  (let ((tls (frame-top-level-sheet frame))
	(canvas (get-frame-pane frame 'canvas)))
    (format t "spawn-thread\n")
    (setf (clock-process frame)
	  (portable-threads:spawn-thread
	   "clock"
	   #'(lambda ()
	       (loop
		  :do
		  (sleep 0.5)
		  (queue-event tls (make-instance 'redraw-clock-event :sheet canvas))
		  ))))
    (format t "~a\n" (clock-process frame))
    (call-next-method)
    (format t "return from call-next-method~%")
    (when (clock-process frame)
      (portable-threads:kill-thread (clock-process frame)))))

(defun run ()
  (run-frame-top-level
   (make-application-frame 'clock-frame)))

;;(run)

paneの:display-timeあたりをどうにかするとうまいことできたりするのだろうか。

cl-ppcreでマッチした文字列に$1などとしてアクセスする

cl-ppcreで正規表現にマッチした文字列を自動的に変数に代入してしまおうというネタ。きっと多くの人が一度はやったことあるに違いない。あるいはやる価値を感じていないか。

register-groups-bindのほうがどう考えても便利だけど、見た目で他の言語のユーザを引きつける事が出来る・・・かも。

(cl-interpol:enable-interpol-syntax)
(defparameter $0 nil)

;;;mkstr,symbはOnLispのもの。
(defun mkstr (&rest args)
 (with-output-to-string (s)
   (dolist (a args)
     (princ a s))))

(defun symb (&rest args)
 (values (intern (apply #'mkstr args))))

(defun =~ (regexp str &rest options)
 (multiple-value-bind (start end reg-start-array reg-end-array)
     (apply #'cl-ppcre:scan regexp str options)
   (when (and (numberp start) (numberp end))
     (set (symb "$0") (subseq str start end))
     (loop
  :for s across reg-start-array
  :for e across reg-end-array
  :for i from 1
  :do
  (set (symb "$" i)
       (subseq str s e))))
   (values start end reg-start-array reg-end-array)))

以下、使用例。

CL-USER> (=~ #?/(\d{4})\/(\d{2})\/(\d{2})/ "2010/02/04")
0
10
#(0 5 8)
#(4 7 10)
CL-USER> (list $0 $1 $2 $3)
("2010/02/04" "2010" "02" "04")

問題は値の代入が(symbol-value $0)に対して行われること。 letなどでレキシカル変数を使っていると意図した挙動にならないかもしれない。

CL-USER> (let ($0 $1 $2 $3 $4)
    (=~ #?/(.{2})(.{3})(.{4})(.*)/ "abcdefghijklmnopqr")
    (list $0 $1 $2 $3 $4))
("abcdefghijklmnopqr" NIL NIL NIL NIL)
CL-USER> (list $0 $1 $2 $3 $4)
(NIL "ab" "cde" "fghi" "jklmnopqr")

・・・ってあれ、なんで$0だけこうなるんだろう。

そうか、defparameterのせいだ。消しとこう。

;;;(defparameter $0 nil)を消した
CL-USER> (let ($0 $1 $2 $3 $4)
    (=~ #?/(.{2})(.{3})(.{4})(.*)/ "abcdefghijklmnopqr")
    (list $0 $1 $2 $3 $4))
(NIL NIL NIL NIL NIL)
CL-USER> (list $0 $1 $2 $3 $4)
("abcdefghijklmnopqr" "ab" "cde" "fghi" "jklmnopqr")