module Graphics.UI.GLUT.Turtle.GLUTools (
	initialize,
	createWindow,
	printCommands,
	keyboardCallback,
	keyboardMouseCallback,
	displayAction,
	loop,
	windowColor,

	currentWindow,
--	separateLine,

	windowSize,
	setWindowSize,
	leaveUnless,

	Key(..),
	glDrawLine,
	drawPolygon,
	glWriteString,

	module Graphics.UI.GLUT
) where

import Graphics.UI.GLUT.Turtle.Triangles

import Graphics.UI.GLUT hiding (
	initialize, createWindow, keyboardMouseCallback, currentWindow,
	windowSize, Key(..), SpecialKey, Color)
import qualified Graphics.UI.GLUT as G
import System.Environment
import Control.Monad
import Data.IORef
import Data.IORef.Tools
import Control.Applicative

data Key = Char Char | MouseButton Int | SpecialKey SpecialKey
	deriving Show

data SpecialKey = SK
	deriving Show

initialize :: IO [String]
initialize = do
	prgName <- getProgName
	rawArgs <- getArgs
	args <- G.initialize prgName rawArgs
	initialDisplayMode $= [RGBMode, DoubleBuffered]
	return args

createWindow :: String -> Int -> Int -> IO Window
createWindow name w h = do
	initialWindowSize $= Size (fromIntegral w) (fromIntegral h)
	G.createWindow name

printCommands :: G.Window -> [String] -> IO ()
printCommands win strs =
	concatMap reverse <$> mapM separateLine strs >>= printCommands_ win

printCommands_ :: G.Window -> [String] -> IO ()
printCommands_ win strs = do
	G.currentWindow $= Just win
	G.clearColor $= G.Color4 0 0 0 0
	G.clear [G.ColorBuffer]
	G.lineWidth $= 1.0
	zipWithM_ (printString (-2.8)) [-1800, -1600 .. 1800] strs
	G.swapBuffers

separateLine :: String -> IO [String]
separateLine "" = return []
separateLine str = do
	n <- getStringNum str 1
	rest <- separateLine (drop n str)
	return $ take n str : rest

getStringNum :: String -> Int -> IO Int
getStringNum str n
	| n >= length str = return n
	| otherwise = G.preservingMatrix $ do
		sw <- G.stringWidth G.Roman (take n str)
		if sw < 3900
			then getStringNum str (n + 1) else return n

printString :: G.GLfloat -> G.GLfloat -> String -> IO ()
printString x y str =
	G.preservingMatrix $ do
		G.scale (0.0005 :: G.GLfloat)  0.0005 0.0005
		G.clearColor $= G.Color4 0 0 0 0
		G.color (G.Color4 0 1 0 0 :: G.Color4 G.GLfloat)
		w <- G.stringWidth G.Roman "Stroke font"
		G.translate (G.Vector3 (x * fromIntegral w)
			y 0 :: G.Vector3 G.GLfloat)
		G.renderString G.Roman str

keyboardCallback ::
	(Char -> G.KeyState -> G.Modifiers -> IO ()) -> IO ()
keyboardCallback f = G.keyboardMouseCallback $= Just (\k ks m _ -> case k of
	G.Char chr -> f chr ks m
	_ -> return ())

keyboardMouseCallback ::
	(Key -> G.KeyState -> G.Modifiers -> (Double, Double) -> IO ()) -> IO ()
keyboardMouseCallback fun = (G.keyboardMouseCallback $=) $ Just $
	\k ks m (Position x y) ->fun (gKeyToKey k) ks m (fromIntegral x, fromIntegral y)

gKeyToKey :: G.Key -> Key
gKeyToKey (G.Char c) = Char c
gKeyToKey (G.MouseButton b) = MouseButton $ buttonToInt b
gKeyToKey (G.SpecialKey _) = SpecialKey SK

buttonToInt :: G.MouseButton -> Int
buttonToInt G.LeftButton = 1
buttonToInt G.MiddleButton = 2
buttonToInt G.RightButton = 3
buttonToInt G.WheelUp = 4
buttonToInt G.WheelDown = 5
buttonToInt (G.AdditionalButton n) = n

displayAction :: IORef Int -> IO () -> IO ()
displayAction changed act = loop_ changed act >> G.displayCallback $= act

loop_ :: IORef Int -> IO a -> IO ()
loop_ changed act = G.addTimerCallback 10 $ timerAction changed act

loop :: IO a -> IO ()
loop act = G.addTimerCallback 10 $ timerAction' act

timerAction :: IORef Int -> IO a -> IO ()
timerAction changed act = do
	c <- readIORef changed
	when (c > 0) $ do
		_ <- act
		atomicModifyIORef_ changed (subtract 1)
	G.addTimerCallback 10 $ timerAction changed act

timerAction' :: IO a -> IO ()
timerAction' act = act >> G.addTimerCallback 10 (timerAction' act)

windowColor_ :: G.Color4 G.GLfloat -> IO ()
windowColor_ clr = G.preservingMatrix $ do
	G.color clr
	G.renderPrimitive G.Quads $ mapM_ G.vertex [
		G.Vertex2 (-1) (-1),
		G.Vertex2 (-1) 1,
		G.Vertex2 1 1,
		G.Vertex2 1 (-1) :: G.Vertex2 G.GLfloat ]

currentWindow :: Window -> IO ()
currentWindow = (G.currentWindow $=) . Just

windowSize :: IO (Int, Int)
windowSize = do
	G.Size w h <- G.get G.windowSize
	return (fromIntegral w, fromIntegral h)

setWindowSize :: Int -> Int -> IO ()
setWindowSize w h = (G.windowSize $=) $ Size (fromIntegral w) (fromIntegral h)

leaveUnless :: Bool -> IO ()
leaveUnless = flip unless G.leaveMainLoop

glDrawLine_ :: G.Color4 G.GLfloat -> G.GLfloat ->
	G.Vertex3 G.GLfloat -> G.Vertex3 G.GLfloat -> IO ()
glDrawLine_ c w p q = G.preservingMatrix $ do
	G.lineWidth $= w
	G.color c
	G.renderPrimitive G.Lines $ mapM_ G.vertex [p, q]

drawPolygon_ :: [G.Vertex3 G.GLfloat] -> G.Color4 G.GLfloat -> G.Color4 G.GLfloat ->
	G.GLfloat -> IO ()
drawPolygon_ [] _ _ _ = error "bad polygon"
drawPolygon_ ps c lc lw = G.preservingMatrix $ do
	G.color c
	G.renderPrimitive G.Triangles $ mapM_ G.vertex ps'
	G.lineWidth $= lw
	G.color lc
	G.renderPrimitive G.LineLoop $ mapM_ G.vertex ps
	where
	ps' = map posToVertex3 $ triangleToPositions $ toTriangles $
		map vertex3ToPos ps

vertex3ToPos :: G.Vertex3 G.GLfloat -> Pos
vertex3ToPos (G.Vertex3 x y 0) =
	(fromRational $ toRational x, fromRational $ toRational y)
vertex3ToPos _ = error "vertex3ToPos: bad"

posToVertex3 :: Pos -> G.Vertex3 G.GLfloat
posToVertex3 (x, y) =
	G.Vertex3 (fromRational $ toRational x) (fromRational $ toRational y) 0

triangleToPositions :: [(Pos, Pos, Pos)] -> [Pos]
triangleToPositions [] = []
triangleToPositions ((a, b, c) : rest) = a : b : c : triangleToPositions rest

glWriteString_ ::
	G.GLfloat -> G.Color4 G.GLfloat -> G.GLfloat -> G.GLfloat -> String -> IO ()
glWriteString_ s clr x y str = G.preservingMatrix $ do
	G.color clr
	G.scale (s :: G.GLfloat) (s :: G.GLfloat) (s :: G.GLfloat)
	G.translate (G.Vector3 x y 0 :: G.Vector3 G.GLfloat)
	G.renderString G.Roman str

drawPolygon :: [Pos] -> Clr -> Clr -> Double -> IO ()
drawPolygon ps c lc lw = drawPolygon_ (map doublesToVertex3 ps) (intsToColor4 c)
	(intsToColor4 lc) (doubleToGLfloat lw)

type Pos = (Double, Double)
type Clr = (Int, Int, Int)

doublesToVertex3 :: (Double, Double) -> Vertex3 GLfloat
doublesToVertex3 (x, y) = Vertex3 (doubleToGLfloat x) (doubleToGLfloat y) 0

intsToColor4 :: (Int, Int, Int) -> Color4 GLfloat
intsToColor4 (r, g, b) = Color4
	(fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) 0

doubleToGLfloat :: Double -> GLfloat
doubleToGLfloat = fromRational . toRational

glDrawLine :: (Int, Int, Int) -> Double -> Pos -> Pos -> IO ()
glDrawLine c w p q = glDrawLine_ (intsToColor4 c) (doubleToGLfloat w)
	(doublesToVertex3 p) (doublesToVertex3 q)

glWriteString :: Double -> Clr -> Pos -> String -> IO ()
glWriteString size clr (x, y) str =
	glWriteString_ (doubleToGLfloat size) (intsToColor4 clr)
		(doubleToGLfloat x) (doubleToGLfloat y) str

windowColor :: Clr -> IO ()
windowColor clr = windowColor_ $ intsToColor4 clr