{-# LANGUAGE LambdaCase #-}

module Main where

import qualified Data.ByteString.Lazy as BS
import           Data.IORef
import           Graphics.UI.Gtk.Cairo
import           Graphics.UI.Gtk hiding (eventButton, eventKeyVal)
import           Graphics.UI.Gtk.Gdk.Events(Event(..),eventX,eventY,eventButton)
import qualified Graphics.Rendering.Cairo as C
import qualified Image.VK as VK

data ApplicationState = ApplicationState
  { apLines  :: [[(Int, Int)]]
  , apCursor :: Maybe (Int, Int)
  , apSize   :: (Int,Int)
  , apGrid   :: Maybe (Int, Int)
  } deriving (Eq, Show)

rnd :: Double -> Int
rnd x = ((floor x) `div` 10) * 10

dLine :: [(Int, Int)] -> C.Render ()
dLine [] = return ()
dLine [(x,y)] = do
  C.moveTo (fromIntegral x) (fromIntegral y)
  C.lineTo (fromIntegral x) (fromIntegral y)
  C.stroke
dLine ((x,y):rs) = do
  C.moveTo (fromIntegral x) (fromIntegral y)
  sequence_ [ C.lineTo (fromIntegral x') (fromIntegral y')
            | (x', y') <- rs
            ]
  C.stroke

dPoints :: [(Int, Int)] -> C.Render ()
dPoints ps =
  sequence_ [ C.arc (fromIntegral x) (fromIntegral y) 2.0 0.0 (2 * pi) >>
              C.stroke
            | (x, y) <- ps
            ]

render :: WidgetClass d => d -> ApplicationState -> IO ()
render d state = do
  dw <- widgetGetDrawWindow d
  (w, h) <- drawableGetSize dw
  region <- regionRectangle (Rectangle 0 0 w h)
  drawWindowBeginPaintRegion dw region
  renderWithDrawable dw $ do
    C.setSourceRGB 1.0 1.0 1.0
    C.rectangle 0 0 (fromIntegral w) (fromIntegral h)
    C.fill
    case apGrid state of
      Nothing -> return ()
      Just (xW, yW) -> do
        C.setSourceRGB 0.8 0.8 0.8
        C.setLineWidth 2
        C.setLineCap C.LineCapRound
        sequence_ [ dot (fromIntegral (x * xW)) (fromIntegral (y * yW))
                  | x <- [0..(w `div` xW)]
                  , y <- [0..(h `div` yW)]
                  ]
    C.setSourceRGB 0.0 0.0 0.0
    mapM_ dLine (apLines state)
    case apLines state of
      [] -> return ()
      (x:xs) -> do
        mapM_ dPoints xs
        C.setSourceRGB 0.0 1.0 1.0
        dPoints x
    C.setSourceRGB 1.0 0.0 0.0
    case apCursor state of
      Nothing -> return ()
      Just (x, y) -> do
        C.arc (fromIntegral x) (fromIntegral y) 5.0 0.0 (2 * pi)
        C.stroke
  drawWindowEndPaint dw

dot :: Double -> Double -> C.Render ()
dot x y = do
  C.moveTo x y
  C.lineTo x y
  C.stroke

main :: IO ()
main = do
  _ <- initGUI
  window <- windowNew
  vbox <- vBoxNew False 10
  da <- drawingAreaNew
  minibuf <- labelNew (Just ":" :: Maybe String)
  stRef <- newIORef (ApplicationState [[]] Nothing (800, 800) (Just (10, 10)))
  set window [ windowDefaultWidth   := 800
             , windowDefaultHeight  := 800
             , containerChild       := vbox
             , containerBorderWidth := 10
             ]
  boxPackStart vbox da PackGrow 0
  boxPackStart vbox minibuf PackRepel 0
  _ <- onMotionNotify da True $ \ event -> do
    st <- readIORef stRef
    let (x, y) = (rnd (eventX event), rnd (eventY event))
    let st' = st { apCursor = Just (x, y) }
    render da st'
    writeIORef stRef st'
    return True
  _ <- onButtonPress da $ \ event ->
    if eventButton event == RightButton
      then do
        st <- readIORef stRef
        let st' = st { apLines = [] : apLines st }
        writeIORef stRef st'
        return True
      else do
        st <- readIORef stRef
        let (x, y) = (rnd (eventX event), rnd (eventY event))
        let st' = st { apLines = ((x, y) : head (apLines st)) : tail (apLines st) }
        writeIORef stRef st'
        render da st'
        return True
  _ <- onKeyPress window $ \ case
    Key { eventKeyChar = Just 'c' } -> do
      modifyIORef stRef (\ st -> st { apLines = [[]] })
      readIORef stRef >>= render da
      return True
    Key { eventKeyChar = Just ':' } -> do
      labelSetText minibuf ("command" :: String)
      return True
    _ -> return True
  _ <- window `onDestroy` (saveFile stRef >> mainQuit)
  widgetShowAll window
  mainGUI

saveFile :: IORef ApplicationState -> IO ()
saveFile ref = do
  st <- readIORef ref
  let (w, h) = apSize st
  let bs = VK.encode $ VK.VKImage
             { VK.vkLines = [ [ (fromIntegral x, fromIntegral y)
                              | (x, y) <- line
                              ]
                            | line <- apLines st
                            ]
             , VK.vkMeta = VK.VKMeta (fromIntegral w, fromIntegral h)
             }
  BS.writeFile "/tmp/tmp.vk" bs