GLUTを使うと,様々なプラットフォーム上で動作するOpenGLのアプリケーションが簡単に書けます.~
 GHCには標準でこのライブラリが含まれるので,色々試してみようと思います.~
 
 #contents
 
 *GLUTのインストール [#jb93d985]
 GLUTを使ったプログラムの実行には,GLUTのライブラリが必要です.~
 インターネット上にたくさん情報があるので調べてください.~
 [[for WIN32>http://www.xmission.com/~nate/glut.html]]
 
 *$=演算子 [#q1f2be5b]
 GLUTのコールバック関数の登録等には,$=演算子を使います.~
 
 $=演算子はHasSetterクラスのメソッドで,実際には
 StateVar型に対してよく使う気がします.
 この型はStateモナドと同じような物で,状態を持つ為に使います.
 
 
 $=演算子はStateVar型の状態を更新する為に使います.~
 例えば~
  clearColor $= Color4 0.0 0.0 0.0 0.0
 とすると,clear関数でColorBufferをクリアする時に
 「Color4 0.0 0.0 0.0 0.0」でクリアされる事になります.~
 http://www.haskell.org/ghc/docs/latest/html/libraries/OpenGL/Graphics-Rendering-OpenGL-GL-Framebuffer.html#v%3Aclear
 
 C言語が分かる方なら~
 GLUTの設定を保持する為の,StateVar型のグローバル変数(clearColor等)があって
 その変数に値を代入する為に,$=演算子を使う.~
 と思っておいて,問題は無いと思います.~
 (色々なHaskellの偉い方に怒られそうですが^^;~
 
 *四角形をぐるぐる回す [#s3c7b8a7]
 四角形がぐるぐる回るサンプルプログラムです.~
 -GLUTの初期化~
 -変数(的な物)を扱って角度を格納~
 
 を試してみました.
 #plain(){{
 import Graphics.UI.GLUT
 import Graphics.Rendering.OpenGL.GLU
 
 import Data.IORef
 
 --タイマの間隔
 timerInterval = 40
 
 main = do
 	--回転の角度を初期化
 	rot <- newIORef 0.0
 	
 	--GLUTの初期化
 	initialDisplayMode $= [RGBAMode, DoubleBuffered]
 	initialWindowSize $= Size 640 480
 	
 	--ウィンドウを作る
 	createWindow "guruGuru"
 	
 	--表示に使うコールバック関数の指定
 	displayCallback $= display rot
 	
 	--ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
 	reshapeCallback $= Just reshape
 	
 	--タイマを作る
 	addTimerCallback timerInterval $ timerProc (display rot)
 	
 	--GLUTのメインループに入る
 	mainLoop
 
 display rot = do
 	--回転させる
 	modifyIORef rot (+14.4)
 	r <- readIORef rot
 	
 	--背景を黒にする
 	clearColor $= Color4 0.0 0.0 0.0 0.0
 	clear [ColorBuffer]
 	
 	--単位行列を読み込む
 	loadIdentity
 	
 	--表示
 	preservingMatrix $ do
 		rotate r (Vector3 0.0 0.0 1.0 :: Vector3 GLdouble)
 		renderPrimitive Quads $ mapM_ vertex [
 	                Vertex3 0.10 0.10 0.0,
 	                Vertex3 (-0.10) 0.10 0.0,
 			Vertex3 (-0.10) (-0.10) 0.0,
 			Vertex3 0.10 (-0.10) 0.0 :: Vertex3 GLfloat]
 	
 	--バッファの入れ替え
 	swapBuffers
 
 --タイマが呼ばれるたびにactを繰り返す
 timerProc act = do
 	act
 	addTimerCallback timerInterval $ timerProc act
 	
 --ウィンドウのサイズが変更された時の処理
 reshape size@(Size w h)=do
 	viewport $= (Position 0 0, size) --ウィンドウ全体を使う
 	
 	--ビューボリュームの設定
 	matrixMode $= Projection
 	loadIdentity
 	perspective 60.0 (fromIntegral w / fromIntegral h) 0.001 50.0
 	
 	--少し後ろから撮影
 	lookAt (Vertex3 0.0 0.0 (-1.0)) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)
 	matrixMode $= Modelview 0
 
 }}
 main.hs等のファイル名で保存して~
  ghc -package GLUT main.hs
 としてやれば実行ファイルができます.
 
 **解説 [#i00a812d]
 回転の角度を格納するのに,今回はIORefモナドを使う事にしました.~
 モナドと聞くと難しいイメージがありますが,道具として簡単に使うだけなら~
 詳細な理論等は気にしないでOKです.これを使う為に~
  import Data.IORef
 としてモジュールを読み込みます.~
 このIORefを使うと,C++で言う所の参照を扱う事ができます.例えば
  ref <- newIORef 1
 とすると,refには1を持つ変数への参照を返します.C++での~
  ref = new int(1);
 に似ていますね.~
 refは参照なので,そのままでは整数として扱えません.
  r <- readIORef ref
 のようにすると,整数を取り出す事ができます.~
 このIORefには他にもwriteIORefやmodifyIORef等の関数が使えます.使い方はソースコードを読めば分かると思います.
 
 *キーボードからの入力を受ける [#c51af855]
 キーボードの動きに応じて動作を変える事ができれば,時間とやる気しだいで何でも作れますね(本当かな?^^;).~
 先ほどのプログラムに少しコードを書き足して,キーボードの入力で回転の方向が変わるようにしてみます.~
 **コード [#n6b46839]
 #plain(){{
 import Graphics.UI.GLUT
 import Graphics.Rendering.OpenGL.GLU
 
 import System
 import Data.IORef
 
 --タイマの間隔
 timerInterval = 40
 
 main = do
 	--回転の角度を初期化
 	rot <- newIORef 0.0
 	arg <- newIORef 14.4
 	
 	--GLUTの初期化
 	initialDisplayMode $= [RGBAMode, DoubleBuffered]
 	initialWindowSize $= Size 640 480
 	
 	--ウィンドウを作る
 	createWindow "guruGuru"
 	
 	--表示に使うコールバック関数の指定
 	displayCallback $= display rot arg
 	
 	--ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
 	reshapeCallback $= Just reshape
 	
 	--キーボードやマウスのコールバック
 	keyboardMouseCallback $= Just (keyboardProc arg)
 	
 	--タイマを作る
 	addTimerCallback timerInterval $ timerProc (display rot arg)
 	
 	--GLUTのメインループに入る
 	mainLoop
 
 display rot arg= do
 	--回転させる
 	w<-readIORef arg 
 	--w <- readIORef hoge
 	modifyIORef rot (+w)
 	r <- readIORef rot
 	
 	--背景を黒にする
 	clearColor $= Color4 0.0 0.0 0.0 0.0
 	clear [ColorBuffer]
 	
 	--単位行列を読み込む
 	loadIdentity
 	
 	--表示
 	preservingMatrix $ do
 		rotate r (Vector3 0.0 0.0 1.0 :: Vector3 GLdouble)
 		renderPrimitive Quads $ mapM_ vertex [
 	                Vertex3 0.10 0.10 0.0,
 	                Vertex3 (-0.10) 0.10 0.0,
 			Vertex3 (-0.10) (-0.10) 0.0,
 			Vertex3 0.10 (-0.10) 0.0 :: Vertex3 GLfloat]
 	
 	--バッファの入れ替え
 	swapBuffers
 
 --タイマが呼ばれるたびにactを繰り返す
 timerProc act = do
 	act
 	addTimerCallback timerInterval $ timerProc act
 	
 --ウィンドウのサイズが変更された時の処理
 reshape size@(Size w h)=do
 	viewport $= (Position 0 0, size) --ウィンドウ全体を使う
 	
 	--ビューボリュームの設定
 	matrixMode $= Projection
 	loadIdentity
 	perspective 60.0 (fromIntegral w / fromIntegral h) 0.001 50.0
 	
 	--少し後ろから撮影
 	lookAt (Vertex3 0.0 0.0 (-1.0)) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)
 	matrixMode $= Modelview 0
 	
 --キー入力の処理
 keyboardProc arg ch state _ _
 	| ch 	== Char 'q'	= exitWith ExitSuccess		--qが押されたら終了
 	| state	== Down		= modifyIORef arg (*(-1))	--それ以外なら回転の方向を変える
 	| otherwise			= return ()
 
 }}
 こんな感じです.先ほどと同じく
  ghc -package GLUT main.hs
 とすればコンパイルできます.
 **変更点 [#f4d909ad]
  keyboardMouseCallback $= Just (keyboardProc arg)
 これでキーボードやマウスにイベントが起こった時に呼ばれるコールバック関数を指定します.~
 argは一度に回転させる角度を格納した変数への参照です.~
  keyboardProc arg ch state _ _
  	| ch 	== Char 'q'	= exitWith ExitSuccess		--qが押されたら終了
  	| state	== Down		= modifyIORef arg (*(-1))	--それ以外なら回転の方向を変える
  	| otherwise			= return ()
 このkeyboardProcがキーを押した時に呼ばれます.詳しい説明は[[こちら>http://www.haskell.org/ghc/docs/latest/html/libraries/GLUT/Graphics-UI-GLUT-Callbacks-Window.html#5]]を読んでください.~
 chはキーの種類,stateに押したのか離したのかが格納されています.~
 ガード部で,qが押された時に終了,それ以外のキーが押された時に回転方向を反転するようにしました.
 
 *パーティクル [#w17b0ceb]
 #ref(./particle.png,50%)
 Haskellで乱数を扱ってみます.~
 左の点からランダムにパーティクルが飛びだします.
 モナドの扱いにまだ慣れていないせいか,型チェックに引っかかって,なかなかコンパイルが通りませんでした^^;~
 
 **ソース [#r7acbda4]
 #plain(){{
 module Main where
 
 import Graphics.UI.GLUT hiding (position)
 import Graphics.Rendering.OpenGL.GLU
 
 import System
 import System.Random
 import Data.IORef
 
 --タイマの間隔
 timerInterval = 16
 
 type Point= Vertex3 GLdouble
 data GameObject = Particle{position::Point, velocity::Point}
 data GameState = Game{objects::[GameObject]}
 data GameRenderer=Renderer{rendererFunc::DisplayCallback, game::IORef GameState}
 
 updateObject::GameObject->GameObject
 updateObject Particle{position=pos, velocity=vel}
 	=Particle{
 		position = addVer3 pos vel,
 		velocity = addVer3 vel (Vertex3 0.0 (-0.001) 0.0) }
 	where
 		addVer3 (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2)
 			= Vertex3 (x1+x2) (y1+y2) (z1+z2)
 			
 updateObjects::[GameObject]->[GameObject]
 updateObjects os
 	= filter (\o-> getY (position o) >(-0.5))	--ある程度落ちた点は消す
 		$ map updateObject os					--座標を更新する
 	where
 		getY (Vertex3 _ y _) = y
 		
 newParticle::IO GameObject
 newParticle=do
 	newVel <- getRandomVel
 	return Particle{
 		position=Vertex3 0 0 0,
 		velocity=newVel}
 	where
 		getRandomVel::IO Point
 		getRandomVel=do
 			gx <- newStdGen
 			(x,gy) <- return $ randomR ( 0.01, 0.02) gx
 			(y,gz) <- return $ randomR ( 0.01, 0.03) gy
 			(z,g') <- return (0.0, gz) -- $ randomR (-0.02, 0.02) gz
 			return $ Vertex3 x y z
 
 newParticles::Int->IO [GameObject]
 newParticles 0 = return []
 newParticles n = do
 	p <- newParticle
 	ps<- newParticles $ n-1 
 	return $ p:ps
 	
 main = do
 	--Gameを作る
 	p <- newParticle
 	gameState <- newIORef Game{objects=[p]}
 	gameRenderer <- newIORef Renderer{
 		rendererFunc=display gameState, game=gameState}
 	--GLUTの初期化
         initialDisplayMode $= [RGBAMode, DoubleBuffered]
         initialWindowSize $= Size 640 480
 	
 	--ウィンドウを作る
 	createWindow "Particle"
 	
 	--表示に使うコールバック関数の指定
 	displayCallback $= display gameState-- gameState
 	
 	--ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
 	reshapeCallback $= Just reshape
 	
 	--キーボードやマウスのコールバック
 	keyboardMouseCallback $= Just (keyboardProc)
 	
 	--タイマを作る
 	addTimerCallback timerInterval $ timerProc gameRenderer
 	
 	--GLUTのメインループに入る
 	mainLoop
 
 display gameState= do
 	--背景を黒にする
 	clearColor $= Color4 0.0 0.0 0.0 0.0
 	clear [ColorBuffer]
 	
 	--単位行列を読み込む
 	loadIdentity
 	
 	gs <- readIORef gameState
 	pointSize $=4.0
 	--表示
 	preservingMatrix $ do
 		renderPrimitive Points $ mapM_
 			vertex$ map position (objects gs)
 	--バッファの入れ替え
 	swapBuffers
 
 --タイマが呼ばれるたびにactを繰り返す
 timerProc::IORef GameRenderer->IO ()
 timerProc grRef = do
 	gr <- readIORef grRef
 	gs <- readIORef $ game gr
 	rendererFunc gr
 	ps <-newParticles 32
 	writeIORef (game gr)
 		Game{
 			objects=ps++(updateObjects$objects gs)}
 	addTimerCallback timerInterval $ timerProc grRef
 	
 --ウィンドウのサイズが変更された時の処理
 reshape size@(Size w h)=do
 	viewport $= (Position 0 0, size) --ウィンドウ全体を使う
 	
 	--ビューボリュームの設定
 	matrixMode $= Projection
 	loadIdentity
 	perspective 60.0 (fromIntegral w / fromIntegral h) 0.001 50.0
 	
 	--少し後ろから撮影
 	lookAt (Vertex3 0.5 0.2 (1.0)) (Vertex3 0.5 0.2 0.0) (Vector3 0.0 1.0 0.0)
 	matrixMode $= Modelview 0
 	
 --キー入力の処理
 keyboardProc ch state _ _
 	| ch 	== Char 'q'	= exitWith ExitSuccess		--qが押されたら終了
 --	| state	== Down		= modifyIORef arg (*(-1))	--それ以外なら回転の方向を変える
 	| otherwise			= return ()
 }}
 
 **解説 [#ob054ee8]
 GLUT的な変更点はありません.~
 指定した範囲の乱数を取得する関数randomRを使ってみました.~
 使い方は[[ここ>http://www.sampou.org/haskell/report-revised-j/random.html]]が参考になると思います.~
 
 *彗星 [#q86f476d]
 #ref(./particle2.png,50%);
 矢印キーで,パーティクルを飛ばしながら飛行する物体を操作できます.~
 **ソース [#e601b446]
 今回もHaskell的で無いです.
 #plain(){{
 module Main where
 
 import Graphics.UI.GLUT hiding (position)
 import Graphics.Rendering.OpenGL.GLU
 
 import System
 import System.Random
 import Data.IORef
 import Control.Monad
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 --タイマの間隔
 timerInterval = 16
 
 type Point= Vertex3 GLdouble
 
 data GameObject =
 		Particle{position::Point, velocity::Point}
 	|	Player{position::Point, velocity::Point}
 
 data GameState = Game{
 	player::GameObject,
 	objects::[GameObject],
 	keys::IORef (Set.Set Key)}
 data GameRenderer=Renderer{rendererFunc::DisplayCallback, game::IORef GameState}
 
 addVer3::Num a => Vertex3 a->Vertex3 a->Vertex3 a
 addVer3 (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2)
 			= Vertex3 (x1+x2) (y1+y2) (z1+z2)
 subVer3::Num a => Vertex3 a->Vertex3 a->Vertex3 a
 subVer3 (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2)
 			= Vertex3 (x1-x2) (y1-y2) (z1-z2)
 			
 updateObject::GameObject->GameObject
 updateObject Particle{position=pos, velocity=vel}
 	=Particle{
 		position = addVer3 pos vel,
 		velocity = vel}-- 重力ON addVer3 vel (Vertex3 0.0 (-0.001) 0.0) }
 
 			
 updateObjects::[GameObject]->[GameObject]
 updateObjects os
 	= map updateObject os 
 	-- filter (\o-> getY (position o) >(-0.5))	--ある程度落ちた点は消す
 	-- $ map updateObject os					--座標を更新する
 	where
 		getY (Vertex3 _ y _) = y
 	
 newParticle::Point->Point->IO GameObject
 newParticle p v=do
 	newVel <- getRandomVel
 	return Particle{
 		position=p,
 		velocity=addVer3 v newVel}
 	where
 		getRandomVel=do
 			gx <- newStdGen
 			(x,gy) <- return $ randomR ( -0.003, 0.003) gx
 			(y,gz) <- return $ randomR ( -0.003, 0.003) gy
 			(z,g') <- return $ randomR ( -0.003, 0.003) gz
 			return $ Vertex3 x y z
 
 --個数 場所 方向
 newParticles::Int->Point->Point->IO [GameObject]
 newParticles 0 _ _ = return []
 newParticles n p v= do
 	new <- newParticle p v
 	ps<- newParticles (n-1) p v
 	return (new:ps)
 	
 main = do
 	--Gameを作る
 	keyState <- newIORef Set.empty
 	gameState <- newIORef Game{
 		player=Player{position=Vertex3 0 0 0, velocity=Vertex3 0 0 0},
 		objects=[],
 		keys=keyState}
 	gameRenderer <- newIORef Renderer{
 		rendererFunc=display gameState, game=gameState}
 	--GLUTの初期化
         initialDisplayMode $= [RGBAMode, DoubleBuffered]
         initialWindowSize $= Size 640 480
 	
 	--ウィンドウを作る
 	createWindow "Particle"
 	
 	--表示に使うコールバック関数の指定
 	displayCallback $= display gameState-- gameState
 	
 	--ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
 	reshapeCallback $= Just (reshape gameState)
 	
 	--キーボードやマウスのコールバック
 	keyboardMouseCallback $= Just (keyboardProc keyState)
 	
 	--タイマを作る
 	addTimerCallback timerInterval $ timerProc gameRenderer
 	
 	--GLUTのメインループに入る
 	mainLoop
 	
 display gameState= do
 	--背景を黒にする
 	clearColor $= Color4 0.0 0.0 0.0 0.0
 	clear [ColorBuffer]
 	
 	--単位行列を読み込む
 	loadIdentity
 	
 	gs <- readIORef gameState
 	
 	setCenter gs
 	
 	pointSize $=4.0
 	--表示
 	showParticles	$ objects gs
 	showPlayer		$ player gs
 	
 	--バッファの入れ替え
 	swapBuffers
 	
 	where
 		showParticles os = preservingMatrix $ do
 			renderPrimitive Points $ mapM_
 				vertex$ map position os
 			
 		showPlayer Player{position=Vertex3 x y z, velocity=_} =
 			preservingMatrix $ do
 				translate (Vector3 x y z)
 				renderObject Wireframe (Sphere' 0.05 5 5)--(Teapot 0.06)
 
 modifyGame::IORef GameState->IO()
 modifyGame game = do
 	gs <- readIORef game
 	ks <- readIORef $ keys gs
 	--プレイヤーを動かす
 	ppos <- return $ position $ player gs
 	pvel <- return $ velocity $ player gs
 	addVecList	<- return $ map (`searchMap` vectorMap) $ Set.elems ks 
 	addVec		<- return $ foldl (addVer3) (Vertex3 0 0 0) addVecList
 	--プレイヤーが動くならパーティクルを吐く
 	Vertex3 x y z <- return addVec
 	ps <-if or [null addVecList, addVec==Vertex3 0 0 0]
 		then return [] 
 		else newParticles 32 (addVer3 ppos pvel) (addVer3 pvel (Vertex3 (-x) (-y) (-z)))
 	newPlayer <- return Player{
 		position=addVer3 ppos pvel,
 		velocity=addVer3 pvel addVec
 	}
 			
 	writeIORef game 
 		Game{
 			player	=newPlayer,
 			objects	=take 10240 $ ps++(updateObjects$objects gs),
 			keys	=keys gs}
 	where
 		searchMap f ((ch,v):xs)= if f==ch then v else searchMap f xs
 		searchMap f []=Vertex3 0 0 0
 		vectorMap = [
 			(SpecialKey KeyLeft,	Vertex3 (-0.003) 0 0),
 			(SpecialKey KeyRight,	Vertex3 0.003 0 0),
 			(SpecialKey KeyUp,		Vertex3 0 0.003 0),
 			(SpecialKey KeyDown,	Vertex3 0 (-0.003) 0)]
 				
 
 timerProc::IORef GameRenderer->IO ()
 timerProc grRef = do
 	gr <- readIORef grRef
 	modifyGame $ game gr
 	gs <- readIORef $ game gr
 	rendererFunc gr
 	addTimerCallback timerInterval $ timerProc grRef
 
 setCenter gs = do
 	Vertex3 x y z <- return $ position$player gs
 	lookAt (Vertex3 0.0 0.0 (1.0)) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)
 	--lookAt (Vertex3 x y (1.0)) (Vertex3 x y 0.0) (Vector3 0.0 1.0 0.0)
 
 --ウィンドウのサイズが変更された時の処理
 reshape gameState size@(Size w h)=do
 	viewport $= (Position 0 0, size) --ウィンドウ全体を使う
 	gs <- readIORef gameState
 	--ビューボリュームの設定
 	matrixMode $= Projection
 	loadIdentity
 	perspective 60.0 (fromIntegral w / fromIntegral h) 0.001 50.0
 	
 	--少し後ろから撮影
 	setCenter gs
 	matrixMode $= Modelview 0
   	
 --キー入力の処理
 keyboardProc keySet ch state _ _
 	| ch 	== Char 'q'	= exitWith ExitSuccess		--qが押されたら終了
 	| state	== Down		= modifyIORef keySet (Set.insert ch)
 	| state	== Up		= modifyIORef keySet (Set.delete ch)
 	| otherwise			= return ()
 }}
 
 **解説 [#s4496b23]
 GLUT的な変更点はありません.~
 IORefなSetを使ってキーの状態を覚えています.この辺り
  | state	== Down		= modifyIORef keySet (Set.insert ch)
  | state	== Up		= modifyIORef keySet (Set.delete ch)
 
 *アルファブレンド [#m8fccc14]
 #ref(./particle3.png,50%);
 半透明に合成できるとかっこいいエフェクトを作る事ができます.~
 
 **注意 [#f9d47735]
 今まではパーティクルの表示にPointsを使っていましたが,私の使っているノートPCがPointSpritesに未対応だった為~
 今後の事を考え,今回から3DSprite(ビルボード)を利用しています((今回のプログラムはPointSprites未対応でもPointsで表示できると思います)).
 
 **ソース [#ma73c9e4]
 #plain(){{
 module Main where
 
 import Graphics.UI.GLUT hiding (position)
 import Graphics.Rendering.OpenGL.GLU
 
 import System
 import System.Random
 import Data.IORef
 import Control.Monad
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 --タイマの間隔
 timerInterval = 16
 
 type Point= Vertex3 GLdouble
 
 data GameObject =
 		Particle{position::Point, velocity::Point, temperature::Float}
 	|	Player{position::Point, velocity::Point}
 
 data GameState = Game{
 	player::GameObject,
 	objects::[GameObject],
 	keys::IORef (Set.Set Key)}
 data GameRenderer=Renderer{rendererFunc::DisplayCallback, game::IORef GameState}
 
 addVer3::Num a => Vertex3 a->Vertex3 a->Vertex3 a
 addVer3 (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2)
 			= Vertex3 (x1+x2) (y1+y2) (z1+z2)
 subVer3::Num a => Vertex3 a->Vertex3 a->Vertex3 a
 subVer3 (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2)
 			= Vertex3 (x1-x2) (y1-y2) (z1-z2)
 			
 updateObject::GameObject->GameObject
 updateObject Particle{position=pos, velocity=vel, temperature=temp}
 	=Particle{
 		position = addVer3 pos vel,
 		velocity = vel,
 		temperature=temp-1}
 
 updateObjects::[GameObject]->[GameObject]
 updateObjects [] = []
 updateObjects (o:os)
 	=case o of
 		Particle{position=_, velocity=_, temperature=_} ->
 			if temperature o > 0
 				then updateObject o:(updateObjects os)
 				else updateObjects os
 		otherwise -> updateObjects os
 	where
 		getY (Vertex3 _ y _) = y
 	
 tempAve=50
 newParticle::Point->Point->IO GameObject
 newParticle p v=do
 	newVel <- getRandomVel
 	newTemp<- getRandomTemp
 	return Particle{
 		position=p,
 		velocity=addVer3 v newVel,
 		temperature=newTemp}
 	where
 		getRandomTemp=do
 			g <- newStdGen
 			(t,g') <- return $ randomR (tempAve-10, tempAve+10) g
 			return t
 		getRandomVel=do
 			gx <- newStdGen
 			(x,gy) <- return $ randomR ( -0.006, 0.006) gx
 			(y,gz) <- return $ randomR ( -0.006, 0.006) gy
 			(z,g') <- return $ randomR ( -0.006, 0.006) gz
 			return $ Vertex3 x y z
 
 --個数 場所 方向
 newParticles::Int->Point->Point->IO [GameObject]
 newParticles 0 _ _ = return []
 newParticles n p v= do
 	new <- newParticle p v
 	ps<- newParticles (n-1) p v
 	return (new:ps)
 	
 main = do
 	--Gameを作る
 	keyState <- newIORef Set.empty
 	gameState <- newIORef Game{
 		player=Player{position=Vertex3 0 0 0, velocity=Vertex3 0 0 0},
 		objects=[],
 		keys=keyState}
 	gameRenderer <- newIORef Renderer{
 		rendererFunc=display gameState, game=gameState}
 	--GLUTの初期化
         initialDisplayMode $= [RGBAMode, DoubleBuffered]
         initialWindowSize $= Size 640 480
 	
 	--ウィンドウを作る
 	createWindow "Particle"
 	
 	--表示に使うコールバック関数の指定
 	displayCallback $= display gameState-- gameState
 	
 	--ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
 	reshapeCallback $= Just (reshape gameState)
 	
 	--キーボードやマウスのコールバック
 	keyboardMouseCallback $= Just (keyboardProc keyState)
 	
 	--タイマを作る
 	addTimerCallback timerInterval $ timerProc gameRenderer
 	
 	--GLUTのメインループに入る
 	mainLoop
 	
 display gameState= do
 	--背景を黒にする
 	clearColor $= Color4 0.0 0.0 0.0 0.0
 	clear [ColorBuffer]
 	
 	blend$=Enabled
 	blendFunc $= (SrcAlpha, OneMinusSrcColor)
 			
 	--単位行列を読み込む
 	loadIdentity
 	
 	gs <- readIORef gameState
 	
 	setCenter gs
 	
 	pointSize $=4.0
 	--表示
 	showParticles	(objects gs)
 	showPlayer		$ player gs
 	
 	--バッファの入れ替え
 	swapBuffers
 	
 	where
 		tempToColor4 t a = Color4 (1.0-0.02*(tempAve-t)) (1.0-0.04*(tempAve-t)) (1.0-0.08*(tempAve-t)) a
 		getSprite w=[
 			Vertex3 (-w) (-w) 0,
 			Vertex3 (-w)   w  0,
 			Vertex3   w  (-w) 0,
 			Vertex3   w  (-w) 0,
 			Vertex3 (-w)   w  0,
 			Vertex3   w    w  0]
 		showParticles []= return ()
 		showParticles (o:os) = do
 			color (tempToColor4 (temperature o) 0.8)
 			preservingMatrix $ renderPrimitive Triangles $ do
 				mapM_ vertex $ map (addVer3 $ position o) $ getSprite 0.04
 			showParticles os
 			
 		showPlayer Player{position=Vertex3 x y z, velocity=_} = do
 			color $ Color3 (1.0::Double) 1.0 1.0
 			preservingMatrix $ do
 				translate (Vector3 x y z)
 				renderObject Wireframe (Sphere' 0.05 5 5)--(Teapot 0.06)
 
 modifyGame::IORef GameState->IO()
 modifyGame game = do
 	gs <- readIORef game
 	ks <- readIORef $ keys gs
 	--プレイヤーを動かす
 	ppos <- return $ position $ player gs
 	pvel <- return $ velocity $ player gs
 	addVecList	<- return $ map (`searchMap` vectorMap) $ Set.elems ks 
 	addVec		<- return $ foldl (addVer3) (Vertex3 0 0 0) addVecList
 	--プレイヤーが動くならパーティクルを吐く
 	Vertex3 x y z <- return addVec
 	ps <-if or [null addVecList, addVec==Vertex3 0 0 0]
 		then return [] 
 		else newParticles 8 (addVer3 ppos pvel) (addVer3 pvel (Vertex3 (-x) (-y) (-z)))
 	newPlayer <- return Player{
 		position=addVer3 ppos pvel,
 		velocity=addVer3 pvel addVec
 	}
 			
 	writeIORef game 
 		Game{
 			player	=newPlayer,
 			objects	=ps++(updateObjects$objects gs),
 			keys	=keys gs}
 	where
 		searchMap f ((ch,v):xs)= if f==ch then v else searchMap f xs
 		searchMap f []=Vertex3 0 0 0
 		vectorMap = [
 			(SpecialKey KeyLeft,	Vertex3 (-0.003) 0 0),
 			(SpecialKey KeyRight,	Vertex3 0.003 0 0),
 			(SpecialKey KeyUp,		Vertex3 0 0.003 0),
 			(SpecialKey KeyDown,	Vertex3 0 (-0.003) 0)]
 				
 
 timerProc::IORef GameRenderer->IO ()
 timerProc grRef = do
 	gr <- readIORef grRef
 	modifyGame $ game gr
 	gs <- readIORef $ game gr
 	rendererFunc gr
 	addTimerCallback timerInterval $ timerProc grRef
 
 setCenter gs = do
 	Vertex3 x y z <- return $ position$player gs
 	--lookAt (Vertex3 0.0 0.0 (1.0)) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)
 	lookAt (Vertex3 x y (1.0)) (Vertex3 x y 0.0) (Vector3 0.0 1.0 0.0)
 
 --ウィンドウのサイズが変更された時の処理
 reshape gameState size@(Size w h)=do
 	viewport $= (Position 0 0, size) --ウィンドウ全体を使う
 	gs <- readIORef gameState
 	--ビューボリュームの設定
 	matrixMode $= Projection
 	loadIdentity
 	perspective 60.0 (fromIntegral w / fromIntegral h) 0.001 50.0
 	
 	--少し後ろから撮影
 	setCenter gs
 	matrixMode $= Modelview 0
   	
 --キー入力の処理
 keyboardProc keySet ch state _ _
 	| ch 	== Char 'q'	= exitWith ExitSuccess		--qが押されたら終了
 	| state	== Down		= modifyIORef keySet (Set.insert ch)
 	| state	== Up		= modifyIORef keySet (Set.delete ch)
 	| otherwise			= return ()
 }}
 
 **説明 [#u00533fe]
 アルファブレンドを有効にする為に
  blend$=Enabled
 アルファブレンドの仕方を
  blendFunc $= (SrcAlpha, OneMinusSrcColor)
 のように指定します.~
 後は色を指定する際にColor4を使って,4番目の色の要素に透明度を指定します(0が透明,1.0が不透明)~
  color (Color4 1.0 0 0 0.5) 
 詳しい使い方は,OpenGLの説明をしたページでglBlendFunc関数について調べるとよいでしょう.~
 
 [[公式ページ>http://www.haskell.org/ghc/docs/6.4/html/libraries/OpenGL/Graphics.Rendering.OpenGL.GL.PerFragment.html#8]]
 
 *文字を表示 [#rcacbd18]
 #ref(./string.png,50%);
 GLUTではビットマップフォントとストロークフォントによる文字の描画をサポートしていますが~
 Haskellからもこの機能が利用して文字を描く事ができます.~
 **ソース [#b7df0494]
 #plain(){{
 import Graphics.UI.GLUT
 import Graphics.Rendering.OpenGL.GLU
 
 main = do
     --GLUTの初期化
     initialDisplayMode $= [RGBAMode, DoubleBuffered]
     initialWindowSize $= Size 640 480
     
     --ウィンドウを作る
     createWindow "renderString sample"
     
     --表示に使うコールバック関数の指定
     displayCallback $= display
     
     --ウィンドウのサイズが変更された時に呼ぶコールバック関数の指定
     reshapeCallback $= Just reshape
 
     --GLUTのメインループに入る
     mainLoop
 
 display = do
     --背景を青にする
     clearColor $= Color4 0.0 0.0 1.0 0.0
     clear [ColorBuffer]
     
     --単位行列を読み込む
     loadIdentity
     
     --表示
     lineWidth $= 4.0
     preservingMatrix $ do
         scale (0.001::Double) 0.001 0.001
         w <- stringWidth Roman "Stroke font"
         translate (Vector3 (-0.5*(fromIntegral w)) 0 0 ::Vector3 Float)
         renderString Roman "Stroke font"
     	
     --バッファの入れ替え
     swapBuffers
     
 --ウィンドウのサイズが変更された時の処理
 reshape size@(Size w h)=do
     viewport $= (Position 0 0, size) --ウィンドウ全体を使う
     
     --ビューボリュームの設定
     matrixMode $= Projection
     loadIdentity
     perspective 60.0 (fromIntegral w / fromIntegral h) 0.001 50.0
     
     --少し後ろから撮影
     lookAt (Vertex3 0.0 0.0 1.0) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)
     matrixMode $= Modelview 0
 
 }}
 
 **説明 [#cca6bded]
 ビットマップフォントは思った動作をさせる事ができなかったので使っていません.~
 ストロークフォントの描画には,renderStringを使います.~
 このストロークフォントは,Lineとして書かれているので~
 translateやscale,lineWidth等の関数を適用できます.~
 また,stringWidthを使うことで,文字列を表示した時の幅を求める事もできます.~
 
 [[公式ドキュメント>http://www.haskell.org/ghc/docs/6.4/html/libraries/GLUT/Graphics.UI.GLUT.Fonts.html]]
 
 *参考にした物 [#b279d6c3]
 -[[Haskell Hierarchical Libararies>http://www.haskell.org/ghc/docs/latest/html/libraries/index.html]]~
 GHCのライブラリの説明.
 
 -[[HaskellOpenGl>http://www.haskell.org/hawiki/HaskellOpenGl]]~
 planet.cのHaskellへの移植があります.
 
 -[[モナディックシューティング>http://www.geocities.jp/takascience/index_ja.html]]~
 Haskellで書かれたシューティングゲーム.~
 適度に複雑で,適度にシンプルな分かりやすいサンプルになると思います.
 
 -[[h_sakuraiの日記 -Haskellのシューティングを読む>http://d.hatena.ne.jp/h_sakurai/20050727]]~
 モナディックシューティングの簡単な解説.~
 
 -[[Yet another Reimeinikki -HOpenGL 事始め>http://d.hatena.ne.jp/scinfaxi/20060307]]~
 とてもシンプルなHaskell+OpenGLのコード.
 
 -[[布シミュ>プログラミング/C_C++/布シミュ]]~
 過去に書いたGLUTのプログラム.~
 自分のプログラムが,GLUT思い出すのに一番役に立ちます^^
 
 *コメント [#y6917345]
 -インデントが崩れて,コンパイルが通らない事があるみたいです.報告をいただけたら修正します.
 RIGHT:[[Safii]] &new{2006-09-22 11:44:29 (金)};
 -いくつかのサンプルで”GLUTの初期化”というところのインデントがずれているようです。 -- [[a_kawashiro]] &new{2012-10-25 08:42:09 (木)};
 -Ubuntu + GHC 7.4.1 では”initialWindowSize $= Size 640 480”の下に” initialize "" [] ”を追加しないとコンパイルが通りません -- [[a_kawashiro]] &new{2012-10-25 08:46:11 (木)};
 -” import System ”というところは” import System.Exit ”とすると良いようです。(Ubuntu + GHC 7.4.1) -- [[a_kawashiro]] &new{2012-10-25 08:48:17 (木)};
 
 #comment