module Stones (dboardSet , eventFrame , dstoneSet , counterSet , dButtonSet) where
 
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Control.Applicative  
import States
import VectorMaps
import qualified Data.Map as Map
import BoardOperater (numberStone)				

------ボードの描画
dboard :: MState -> TextureObject -> IO ()
dboard mst tObj = do
	let tb = displayGameBoard mst
	    w = (boardWidth tb)
	    h = (boardHeight tb)
	    x = (boardPosX tb)
	    y = (boardPosY tb)
	    v = (Vector2 x y)
	textureBinding Texture2D $= Just tObj
	texture Texture2D $= Enabled
	
	renderPrimitive Quads $ mapM_ (vertextex v) [ (0 , 0 , 0 , 1)  ,(0 , h , 0 , 0.0) , ( w, h, 1.0 , 0.0),( w , 0 , 1 , 1)]
	texture Texture2D $= Disabled


------ボードの描画--テクスチャ指定
dboardSet :: MState -> TexObjGrp -> Int -> IO ()
dboardSet mst tObGp id = let texboard = (\(Just x) -> x) (Map.lookup KeyTexGameBoard tObGp)
			 in if id < length texboard
				then dboard mst (getTextureObj KeyTexGameBoard tObGp id )
				else dboard mst (getTextureObj KeyTexGameBoard tObGp 0 )


------フレーム枠の描画
eventFrame :: MState -> IO ()
eventFrame mst = do 
		
	mapM_ (eventFrameLineX mst) [0..(fdivBoardNumX mst) ]
	mapM_ (eventFrameLineY mst) [0..(fdivBoardNumY mst) ]
	


------フレーム枠の描画
eventFrameLineX :: MState -> GLfloat -> IO ()
eventFrameLineX mst i = do
	let tb = displayGameBoard mst
	    w = (boardWidth tb)
	    h = (boardHeight tb)
	
	renderPrimitive Lines $ mapM_ (vertifyLine mst) ( [ (i * w / (fdivBoardNumX mst) , 0 )  ,(i * w / (fdivBoardNumY mst) , h )]) 
				
------フレーム枠の描画
eventFrameLineY :: MState -> GLfloat -> IO ()
eventFrameLineY mst j = do
	let tb = displayGameBoard mst
	    w = (boardWidth tb)
	    h = (boardHeight tb)
	
	renderPrimitive Lines $ mapM_ (vertifyLine mst) ( [ ( 0 , j * h / (fdivBoardNumX mst) )  ,(w , j * h / (fdivBoardNumY mst) )]) 

vertifyLine :: MState -> (GLfloat , GLfloat) -> IO ()
vertifyLine mst (x , y) = do
	let tb = displayGameBoard mst
	    posX = (boardPosX tb)
	    posY = (boardPosY tb)
	    vt = (+) <$> (Vector2 x y) <*> (Vector2 (posX ) (posY )) 

	vertex (setVertex vt)

-----指定したIDのセルの位置ベクトルを求める
getCellPos :: MState -> (Vector2 GLint) -> (Vector2 GLfloat) 
getCellPos mst (Vector2 i j) = 	let 	tb = displayGameBoard mst
		      			posX = boardPosX tb
		       			posY = boardPosY tb
		       			w = boardWidth tb
	 	      			h = boardHeight tb
		       			cellW = w / (fdivBoardNumX mst)
		       			cellH = h / (fdivBoardNumY mst) 
		   	      	in (Vector2 (posX + cellW * (fromIntegral i)) (posY + cellH * (fromIntegral j)))

------石の描画
stone :: MState -> TextureObject -> (Vector2 GLint) -> IO ()
stone mst tObj (Vector2 i j) = do
	let tb = displayGameBoard mst
	    gCell = boardCell tb
	    gCellMarginX = cellMarginX gCell
	    gCellMarginY = cellMarginY gCell	
	    w = (boardWidth tb)
	    h = (boardHeight tb)
	    x = (boardPosX tb)
	    y = (boardPosY tb)
	    
            cellW = w / (fdivBoardNumX mst)
            cellH = h / (fdivBoardNumY mst)
	    cellX = x + cellW * (fromIntegral i)
	    cellY = y + cellH * (fromIntegral j)
	    
            cellW' = cellW - gCellMarginX * 2
            cellH' = cellH - gCellMarginY * 2
	    cellX' = cellX + gCellMarginX
	    cellY' = cellY + gCellMarginY
	textureBinding Texture2D $= Just tObj
	texture Texture2D $= Enabled
	
	--renderPrimitive Quads $ mapM_ (vertextex v) [ (0 , 0.0 , 0 , 0)  ,(0 , cellH , 1 , 0) , ( cellW, cellH, 1 , 1),(cellW , 0 , 0 , 1)]
	renderPrimitive Polygon $ mapM_ circletex (zip (circleInRect circleVertexNum cellX' cellY' cellW' cellH') (cycle [(0,0),(1,0),(1,1),(0,1)]  ) )
	
	texture Texture2D $= Disabled


------石の描画--テクスチャ指定
dstoneSet :: MState -> TexObjGrp -> (Vector2 GLint) -> IO ()
dstoneSet mst tObGp v = let texstone = (\(Just x) -> x) (Map.lookup KeyTexStone tObGp)
			    gCells   = gBoardCells mst
			  
		        in
			case (Map.lookup v gCells) of
		Nothing 	-> return ()
		Just SBlack 	-> stone mst (getTextureObj KeyTexStone tObGp 0 ) v 
		Just SWhite	-> stone mst (getTextureObj KeyTexStone tObGp 1 ) v		



------ボタンの描画
dButton :: MState -> TextureObject -> EButton -> IO ()
dButton mst tObj eB = do
	let con = buttonContainer eB
	    w = (containerWidth con)
	    h = (containerHeight con)
	    x = (containerPosX con)
	    y = (containerPosY con)
	    v = (Vector2 x y)
	textureBinding Texture2D $= Just tObj
	texture Texture2D $= Enabled
	
	renderPrimitive Quads $ mapM_ (vertextex v) [ (0 , 0 , 0 , 1)  ,(0 , h , 0 , 0.0) , ( w, h, 1.0 , 0.0),( w , 0 , 1 , 1)]
	texture Texture2D $= Disabled


------ボタンの描画--テクスチャ指定
dButtonSet :: MState -> DState -> TexObjGrp -> ButtonName -> IO ()
dButtonSet mst dst tObGp eBN = let bTex = buttonNameTex eBN
				   texboard = (\(Just x) -> x) (Map.lookup bTex tObGp)
			           btN = eButtons dst
				   eB = Map.lookup eBN btN
			       in case eB of
			Nothing -> return ()
			Just b  ->dButton mst (getTextureObj bTex tObGp 0 ) b



-----ButtonNameからテクスチャ指定
buttonNameTex :: ButtonName -> TexObjKey
buttonNameTex bN = case bN of
	ButtonStart1P -> KeyButtonStart1P
	ButtonStart2P -> KeyButtonStart2P


-----与えられたベクトル分だけ移動した後、座標とテクスチャ座標を分離してベクトルのペアを返す
vertexVector:: (Vector2 GLfloat) -> (GLfloat ,GLfloat,GLfloat ,GLfloat) -> ((Vector2 GLfloat) , (Vector2 GLfloat))
vertexVector  v (x ,y, a ,b) = (((+) <$> v <*> (Vector2 x y)), (Vector2 a b))


------座標とテクスチャタプルからrenderPrimitiveで使うIOアクションを返す
vertextex :: (Vector2 GLfloat) -> (GLfloat ,GLfloat,GLfloat ,GLfloat) -> IO ()
vertextex v vt = 	let vertexpair = vertexVector v vt
		 	    vTex = (snd vertexpair)
		    	    vVet = (fst vertexpair)	
	       		in do
			texCoord (setTexCoord vTex) 
			vertex (setVertex vVet)

------座標とテクスチャタプルからrenderPrimitiveで使うIOアクションを返す
circletex :: ((Vector2 GLfloat) , (GLfloat ,GLfloat)) -> IO ()
circletex (v , (a , b)) = let vTex = (Vector2 a b)

	       		  in do
			
			texCoord (setTexCoord vTex) 
			vertex (setVertex v)
									

							
												

setVertex :: (Vector2 GLfloat) -> (Vertex2 GLfloat)
setVertex (Vector2 x y) = (Vertex2 x y) 

setTexCoord :: (Vector2 GLfloat) -> (TexCoord2 GLfloat)
setTexCoord (Vector2 x y) = (TexCoord2 x y) 



-----四角形のなかに内接する円の点
circleInRect :: GLint -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> [(Vector2 GLfloat)]
circleInRect n x y w h = let centerP = Vector2 (x + w / 2) (y + h / 2)
			     r = min (w / 2)  (h / 2)
		         in circlePoints n centerP r




-----円周を構成する点
circlePoints :: GLint -> (Vector2 GLfloat) -> GLfloat -> [(Vector2 GLfloat)]
circlePoints n centerP r = map (vectorAdd centerP) [(Vector2 (r * cos (2 * pi * (fromIntegral i) / (fromIntegral n))) (r * sin (2 * pi * (fromIntegral i) / (fromIntegral n)))) | i <- [1..n]]


-----円周の分割数
circleVertexNum :: GLint
circleVertexNum = 20

------カウンター描画
counterSet :: DState -> MState -> TexObjGrp -> CounterKey -> IO ()
counterSet dst mst   tOGp cKey = let cnts = eCounter dst 
			             cnt = Map.lookup cKey cnts
			   	 in case cnt of
		Nothing -> return ()
		Just c  -> do
			let dList = getDegitNumList (counterNumDegit c) (contentCounter mst cKey)
			mapM_ (counterElement c tOGp) dList


------カウンター描画
counterElement :: Counter ->  TexObjGrp -> (GLint , GLint) -> IO ()
counterElement cnt tOGp (i , di) = do
	let con = counterContainer cnt
	    w = ((containerWidth con)  - (containerMarginX con) * 2) / ((fromIntegral (counterNumDegit cnt) )+ 1)
	    h = (containerHeight con) - (containerMarginY con) * 2 
	    ndcnt = (counterNumDegit cnt)
	    tObj = getTextureObj (counterTexKey cnt) tOGp (fromIntegral di)
	    dPos = (Vector2 (w * (fromIntegral (ndcnt - i)) + (containerMarginX con))  (containerMarginY con))
	    conPos = (Vector2 (containerPosX con) (containerPosY con))
	textureBinding Texture2D $= Just tObj
	texture Texture2D $= Enabled
		
	renderPrimitive Quads $ mapM_ (vertextex ((+) <$> conPos <*> dPos)) [ (0 , 0 , 0 , 1)  ,(0 , h , 0 , 0.0) , ( w, h, 1 , 0),( w , 0 , 1 , 1)]
	texture Texture2D $= Disabled



------桁のリスト （再帰）
getDegitNumList :: GLint -> GLint -> [(GLint , GLint)]
getDegitNumList m a 
		| a < 0  = [(0 , 10)] 
		| m < 0 = []
		| a >= (tpm * 10) = (getDegitNumList m (a - 1))	
		| otherwise = (m , ( a `quot` tpm) ) : (getDegitNumList (m - 1) (a `rem` tpm)) 		 
		where tpm = (fromIntegral (10 ^ m)) :: GLint	


-----カウンターの中身
contentCounter :: MState -> CounterKey -> GLint
contentCounter mst ckey = let gbcs = gBoardCells mst
			  in case ckey of
	CWhite -> (numberStone SWhite gbcs)
	CBlack -> (numberStone SBlack gbcs)
	CDebugAI0 -> (mValue1 (mValues mst)) !! 0
	CDebugAI1 -> (mValue1 (mValues mst)) !! 1