module Graphics.X11.Turtle (
	initTurtle,
	closeTurtle,
	shapesize,
	goto,
	forward,
	backward,
	left,
	right,
	penup,
	pendown,
	isdown,
	home,
	circle,
	clear,
	undoAll,
	undo,
	distance,

	Position,
	testModuleTurtle
) where

import Graphics.X11.World
import Data.IORef
import Data.List
import System.IO.Unsafe
import Control.Arrow (second)
import Control.Monad.Tools
import Control.Monad
import Control.Concurrent
import Data.Maybe

world :: IORef World
world = unsafePerformIO $ newIORef undefined

windowWidth :: IO Double
windowWidth = readIORef world >>= fmap fst . getWindowSize

windowHeight :: IO Double
windowHeight = readIORef world >>= fmap snd . getWindowSize

position :: IO (Double, Double)
position = do
	w <- readIORef world
	(x, y) <- getCursorPos w
	width <- windowWidth
	height <- windowHeight
	return (x - width / 2, height / 2 - y)

distance :: Double -> Double -> IO Double
distance x0 y0 = do
	(x, y) <- position
	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)

pastDrawLines :: IORef [Maybe (((Double, Double), Double), IO ())]
pastDrawLines = unsafePerformIO $ newIORef []

data PenState = PenUp | PenDown

doesPenDown :: PenState -> Bool
doesPenDown PenUp = False
doesPenDown PenDown = True

penState :: IORef PenState
penState = unsafePerformIO $ newIORef PenDown

testModuleTurtle :: IO ()
testModuleTurtle = main

main :: IO ()
main = do
	putStrLn "module Turtle"
	initTurtle
	w <- readIORef world
	redrawLines
	withEvent w () $ \() ev ->
		case ev of
			ExposeEvent{} -> do
				drawWorld w
				return ((), True)
			KeyEvent{} -> do
				ch <- eventToChar w ev
				return ((), (ch /= 'q'))
			ClientMessageEvent{} ->
				return ((), not $ isDeleteEvent w ev)
			AnyEvent{ev_event_type = 14} ->
				return ((), True)
			_ -> error $ "not implemented for event " ++ show ev
	closeTurtle

initTurtle :: IO ()
initTurtle = do
	w <- openWorld
	setCursorPos w 100 200
	setCursorDir w 0
	setCursorSize w 2
	setCursorShape w displayTurtle
	drawWorld w
	flushWorld w
	writeIORef world w
	width <- windowWidth
	height <- windowHeight
	setCursorPos w (width / 2) (height / 2)
	drawWorld w
	flushWorld w

shapesize :: Double -> IO ()
shapesize s = do
	w <- readIORef world
	setCursorSize w s
	drawWorld w
	flushWorld w

goto, rawGoto :: Double -> Double -> IO ()
goto x y = do
	width <- windowWidth
	height <- windowHeight
	rawGoto (x + width / 2) (- y + height / 2)
		>> modifyIORef pastDrawLines (++ [Nothing])
rawGoto xTo yTo = do
	w <- readIORef world
	(x0, y0) <- getCursorPos w
	let	step = 10
		distX = xTo - x0
		distY = yTo - y0
		dist = (distX ** 2 + distY ** 2) ** (1 / 2)
		dx = step * distX / dist
		dy = step * distY / dist
	(x', y') <- if (dist <= step) then return (x0, y0) else doWhile (x0, y0) $ \(x, y) -> do
		let	nx = x + dx
			ny = y + dy
		setCursorPos w nx ny
		drawLine w x y nx ny
		drawWorld w
		flushWorld w
		threadDelay 20000
		return ((nx, ny),
			(nx + dx - x0) ** 2 + (ny + dy - y0) ** 2 < dist ** 2)
	setCursorPos w xTo yTo
	drawLine w x' y' xTo yTo
	drawWorld w
	flushWorld w

forward, rawForward :: Double -> IO ()
forward len = rawForward len >> modifyIORef pastDrawLines (++ [Nothing])
rawForward len = do
	w <- readIORef world
	(x0, y0) <- getCursorPos w
	d <- getCursorDir w
	let	rad = d * pi / 180
		nx' = x0 + len * cos rad
		ny' = y0 + len * sin rad
	rawGoto nx' ny'

backward :: Double -> IO ()
backward = forward . negate

penup :: IO ()
penup = writeIORef penState PenUp

pendown :: IO ()
pendown = writeIORef penState PenDown

isdown :: IO Bool
isdown = do
	ps <- readIORef penState
	return $ case ps of
		PenUp -> False
		PenDown -> True

drawLine :: World -> Double -> Double -> Double -> Double -> IO ()
drawLine w x1 y1 x2 y2 = do
	let act = do
		ps <- readIORef penState
		when (doesPenDown ps) $
			lineToBG w (round x1) (round y1) (round x2) (round y2)
	act
	dir <- readIORef world >>= getCursorDir 
	modifyIORef pastDrawLines (++ [Just (((x2, y2), dir), act)])

redrawLines :: IO ()
redrawLines = do
	w <- readIORef world
	dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines
	clear
	flip mapM_ dls $ \dl -> do
		snd dl
		drawWorld w
		flushWorld w
		threadDelay 20000

undoAll :: IO ()
undoAll = do
	w <- readIORef world
	dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines
	flip mapM_ (zip (reverse $ map fst dls) $ map sequence_ $ reverse $ inits $ map snd dls)
		$ \((pos, dir), dl) -> do
		cleanBG w
		dl
		uncurry (setCursorPos w) pos
		setCursorDir w dir
		drawWorld w
		flushWorld w
		threadDelay 20000

undo :: IO ()
undo = do
	w <- readIORef world
	dls <- fmap init $ readIORef pastDrawLines
	let	draw = map (map fromJust . filter isJust)
			$ takeWhile (isJust . last) $ reverse $ inits dls
		draw1 = map fromJust $ filter isJust $ head
			$ dropWhile (isJust . last) $ reverse $ inits dls
		draw' = draw ++ [draw1]
	flip mapM_ (zip (reverse $ map (fst . fromJust) $ filter isJust dls ) $ map sequence_
		$ map (map snd) draw') $ \((pos, dir), dl) -> do
		cleanBG w
		dl
		uncurry (setCursorPos w) pos
		setCursorDir w dir
		drawWorld w
		flushWorld w
		threadDelay 20000
	modifyIORef pastDrawLines $ reverse . dropWhile isJust . tail . reverse

rotateBy :: Double -> IO ()
rotateBy dd = do
	w <- readIORef world
	d0 <- getCursorDir w
	let	nd = (d0 + dd) `gMod` 360
	setCursorDir w nd
	drawWorld w
	flushWorld w
	pos <- getCursorPos w
	modifyIORef pastDrawLines (++ [Just ((pos, nd), return ())])

rotateTo :: Double -> IO ()
rotateTo d = do
	w <- readIORef world
	d0 <- getCursorDir w
	let	step = 5
		dd = d - d0
	replicateM_ (abs dd `gDiv` step) $
		rotateBy (signum dd * step) >> threadDelay 10000
	setCursorDir w d
	drawWorld w
	flushWorld w

rotate, rawRotate :: Double -> IO ()
rotate d = rawRotate d >> modifyIORef pastDrawLines (++ [Nothing])
rawRotate d = do
	w <- readIORef world
	d0 <- getCursorDir w
	rotateTo $ d0 + d

gDiv :: (Num a, Ord a, Integral b) => a -> a -> b
x `gDiv` y
	| x >= y = 1 + (x - y) `gDiv` y
	| otherwise = 0

gMod :: (Num a, Ord a) => a -> a -> a
x `gMod` y
	| x >= y = (x - y) `gMod` y
	| otherwise = x

right :: Double -> IO ()
right = rotate

left :: Double -> IO ()
left = rotate . negate

circle :: Position -> IO ()
circle r = replicateM_ 36 $ do
	rawForward $ (2 * fromIntegral r * pi / 36 :: Double)
	rawRotate (- 10)

home :: IO ()
home = goto 0 0 >> rotateTo 0

clear :: IO ()
clear = do
	w <- readIORef world
	cleanBG w
	drawWorld w >> flushWorld w
	pos <- getCursorPos w
	dir <- getCursorDir w
	modifyIORef pastDrawLines (++ [Just ((pos, dir), cleanBG w)])

closeTurtle :: IO ()
closeTurtle = readIORef world >>= closeWorld

displayTurtle :: World -> Double -> Double -> Double -> Double -> IO ()
displayTurtle w s d x y =
	makeFilledPolygonCursor w $ map (uncurry $ addPoint $ Point (round x) (round y))
		$ map (rotatePointD d)
		$ map (mulPoint s) turtle

addPoint :: Point -> Position -> Position -> Point
addPoint (Point x y) dx dy = Point (x + dx) (y + dy)

rotatePointD :: Double -> (Position, Position) -> (Position, Position)
rotatePointD = rotatePointR . (* pi) . (/ 180)

rotatePointR :: Double -> (Position, Position) -> (Position, Position)
rotatePointR rad (x, y) =
	(x `mul` cos rad - y `mul` sin rad, x `mul` sin rad + y `mul` cos rad)

mulPoint :: Double -> (Position, Position) -> (Position, Position)
mulPoint s (x, y) = (x `mul` s, y `mul` s)

mul :: (Integral a, RealFrac b) => a -> b -> a
x `mul` y = round $ fromIntegral x * y

turtle :: [(Position, Position)]
turtle = ttl ++ reverse (map (second negate) ttl)
	where
	ttl = [
		(- 10, 0),
		(- 8, - 3),
		(- 10, - 5),
		(- 7, - 9),
		(- 5, - 6),
		(0, - 8),
		(4, - 7),
		(6, - 10),
		(8, - 7),
		(7, - 5),
		(10, - 2),
		(13, - 3),
		(16, 0)
	 ]