Programming Windows in Haskell、次の一歩。

もうかれこれ半年以上前のポストの続きになるんですが、なんというか、HaskellでWin32を直にたたくスタイルでGUIアプリを書いてみたわけなんですが、前回挫折したのは、ウィンドウごとのステートをどうやって保持するかというところだったわけです。IORefを作ってその中にステートを書き込んだり読み出したりする方法をHaskellCafeなどでも見かけたりしたのですが、個人的にはなんともしっくり来ていなかったわけです。

先日久しぶりにこの辺のことをごにょごにょといじくってみる気になったので、コードをさわっていたわけです。HaskellでWin32アプリを書いたとき一番最初に僕が試したのはウィンドウのステートをShowしてSetWindowText/GetWindowText経由で保存するという技でした。これをやったときはまだIORefなんていうものも知らず、とにかく何か動かしたいと思ってやったことでした…

そして、次に出てきたのがIORef,Win32の常套手段ではSetWindowLong/GetWindowLongとかあるわけなんですが、なんか、やる気をそそられるものがなかったんですね…

今回、久々に気がむいて手を出してみたのはメッセージポンプの再帰呼び出しを利用して、変化するステートを維持するというモデルでした。スケッチとしては:

pump st = do
	(st', _) <- wndProc st
	pump st'
	
wndProc :: ST->HWND->MSG->WPARAM->LPARAM->
　IO(ST,LRESULT)

なんてものを夢見ていたわけです。でも、無理やり動かしてみると、これはもうWin32のプログラミングのルールを破りまくりで、いろんな形でおかしな動きをしてしまうわけです。

しかし、これをやって気づいたのは、ウィンドウプロシジャにひとつパラメタを追加してやったことで、そのウィンドウに独自の情報をCreateWindowじかに渡すことができることです。あとは、これがうまく変化させられれば良いわけなんです…
ぼーっとGraphics.Win32.Window.createWindowのコードを眺めていると、なぜか、このインプリメンテーションはAPIにユーザー指定のウィンドウプロシジャを渡さずに、その直後にsetWindowClosureという関数でウィンドウプロシジャを指定しています…不思議ですね…

setWindowClosureって、Haskellの関数をWin32のコールバック関数として登録できるのねーとおもって眺めていたら、ちょっと思いついちゃったわけです。といっても、そんな大それたことではないんですけど。

それはつまり、ウィンドウプロシジャ内でウィンドウのステートが変わるたんびに
　　setWindowClosure wndProc st'
とやってやれば、そのウィンドウの状態をうまく管理できそうだということです。

それでやってみたのがこんなのです:

module Main
	where

import System.Win32.Types
import System.Win32.DLL
import Graphics.Win32
import Graphics.Win32.Misc
import Graphics.Win32.GDI.Types 
import Graphics.Win32.Message
import Graphics.Win32.Window
import Data.List (unfoldr)
import Data.Int (Int32)
import Data.Maybe
import Control.Monad
import Control.Arrow

foreign import stdcall "PostQuitMessage" 
　　　postQuitMessage :: Int32 -> IO ()


type Vector = [Float]
type Matrix = [ [Float] ]

transform :: Matrix -> Vector -> Vector
transform mx v = [ (mul r) v| r <- mx]
　where
　　mul rs cs = sum $ zipWith ( * ) rs cs

mxRotXZ :: Float -> Matrix
mxRotXZ rot = [ [cos rot, 0, -1 * (sin rot) ],
　 [0,       1,             0 ],
　[sin rot, 0,       cos rot ] ]

proj :: Vector -> Vector
proj v@(x: y: z: [ ]) = [x * fac, y * fac]
　where
　　fac = (z - zvp) / (zvf - zvp)
　　zvp = -4 :: Float
　　zvf = -1 :: Float

cube :: [Vector]
cube = 	[ [1,  1,  1], [1, -1,  1], [-1, -1,  1], [-1,  1,  1],
　　[1,  1, -1], [1, -1, -1], [-1, -1, -1], [-1,  1, -1],
　　[1,  1,  1], [1,  1, -1], [-1,  1, -1], [-1,  1,  1],
　　[1, -1,  1], [1, -1, -1], [-1, -1, -1], [-1, -1,  1] ]

toMaybe :: Bool -> a -> Maybe a
toMaybe p a
　| p = Just a
　| otherwise = Nothing

varMap :: ( [a] -> (b, [a] ) ) -> [a] -> [b]
varMap f a = unfoldr (uncurry toMaybe . (not.null &&& f) ) a

main = do
　let clsName 	=  mkClassName "My Window Class"
　hinst 		<- getModuleHandle Nothing
　whiteBrush	<- getStockBrush wHITE_BRUSH
　curArrow	<- loadCursor Nothing iDC_ARROW
　mAtom 		<- registerClass
　　(cS_DBLCLKS, 
　　hinst,		-- HINSTANCE
　　Nothing,	-- Maybe HICON
　　Just curArrow,	-- Maybe HCURSOR
　　Just whiteBrush,-- Maybe HBRUSH
　　Nothing,	-- Maybe LPCTSTR
　　clsName)

　when (isJust mAtom) $ do
　　hwnd <- createWindow 
　　　clsName
　　　"Rotating Box Demo" 
　　　(wS_THICKFRAME + wS_CAPTION + wS_SYSMENU) 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　hinst
　　　(wndProc 0)

　　setWinTimer hwnd 0{-tid-} 50{-msec-}

　　showWindow hwnd sW_SHOWNORMAL
　　updateWindow hwnd
　　allocaMessage $ pump

　　unregisterClass clsName hinst

pump lpmsg = do
　fContinue <- getMessage lpmsg Nothing
　when fContinue $ do
　　translateMessage lpmsg
　　dispatchMessage lpmsg
　　pump lpmsg

drawBox4 :: HDC -> [ [Int32] ] -> IO ()
drawBox4 hdc [ [x1, y1], [x2, y2], [x3, y3], [x4, y4] ] = do
　moveToEx hdc x1 y1
　lineTo   hdc x2 y2
　lineTo   hdc x3 y3
　lineTo   hdc x4 y4
　lineTo   hdc x1 y1

drawCube :: HDC -> Matrix -> IO ()
drawCube hdc rot = mapM_ (drawBox4 hdc) $ 
　varMap (splitAt 4) $ 
　map ( 
　　(map $ ( + 400).round.( * 100) ) . proj . transform rot)
　　cube

render :: HWND -> HDC -> Int -> IO ()
render hwnd hdc i  = (drawCube hdc . rot . fromIntegral) i
　where
　　rot :: Float -> Matrix
　　rot x = mxRotXZ $ (pi * x/ 180) 

onTimer :: HWND -> Int -> IO ()
onTimer hwnd i = do
　　invalidateRect (Just hwnd) Nothing True
　　setWindowClosure hwnd (wndProc $ (i + 2) `mod` 360) 

wndProc :: Int -> HWND -> WindowMessage -> WPARAM -> 
　　LPARAM -> IO LRESULT
wndProc i hwnd wm wp lp
　　| wm == wM_KEYDOWN 	= doFinish
　　| wm == wM_LBUTTONDOWN 	= doFinish
　　| wm == wM_DESTROY 	= killTimer (Just hwnd) 0 >> 
　　　　　　　　　　　　　　　postQuitMessage 0 >> return 0
　　| wm == wM_SIZE	= doInvalRender
　　| wm == wM_PAINT   	= onPaint
　　| wm == wM_TIMER	= onTimer hwnd i >> return 0
　　| otherwise 	   = defWindowProc (Just hwnd) wm wp lp
　　where
　　　　doFinish　= sendMessage hwnd wM_CLOSE 1 0 >> return 0
　　　　doInvalRender　= do
　　　　　　　　　invalidateRect (Just hwnd) Nothing True
　　　　　　　　　return 0
　　　　onPaint 	= allocaPAINTSTRUCT $ \ lpps -> do
　　　　　hdc <- beginPaint hwnd lpps
　　　　　render hwnd hdc i
　　　　　endPaint hwnd lpps
　　　　　return 0

昔、Doukakuのお題にあわせてやった簡易３Dアプリなんですが、今回の肝の部分は
wndProcの第一パラメタが（簡単すぎるという話はありますが）ウィンドウの状態を保持しているパラメタ、（回転する箱の角度）そしてそのパラメタがonTimerの中でsetWindowClosureでアップデートされています。

カリー化を使ってステートを管理できるとはなんともHaskellらしくていいかなと思ったわけです。よけいなIORefもいらないし…

ではでは。