module Main where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC
import Data.IORef
import System.IO.Error

------------------------------------------------------------------------------

sizeX, sizeY :: Int
sizeX = 500
sizeY = 400

------------------------------------------------------------------------------

{-
Modelling the drawing state.

**This part of the program is completely independent of GUI-stuff!**
-}

-- a line is a pair of points
type Line = (Point,Point)

{-
"State ls ml" models the drawing state. "ls" contains all the lines already
drawn. "ml" contains a line if we are drawing it right now (holding down the
mouse button). (The line in "ml" will be drawn in red later on.)
-}
data State = State [Line] (Maybe Line)
 deriving (Show, Read)

-- starting state; no lines here
clean :: State
clean = State [] Nothing

-- when we click at point p we start drawing a new line
click :: Point -> State -> State
click p (State ls _) = State ls (Just (p,p))

-- when we unclick at point p we add the new line to the list of lines
unclick :: Point -> State -> State
unclick p (State ls (Just (s,_))) = State ((s,p):ls) Nothing
unclick p st                      = st

-- when we move the mouse we update the current line being drawn
move :: Point -> State -> State
move p (State ls (Just (s,_))) = State ls (Just (s,p))
move p st                      = st

-- undo removes the last line that was drawn (first in the list)
undo :: State -> State
undo (State ls ml) = State (drop 1 ls) ml

-- load/save reads/writes the state to a save-file
saveFile :: FilePath
saveFile = "drawing.txt"

load :: State -> IO State
load _ =
  do ees <- try (readFile saveFile)
     case ees of
       Left _  -> return clean
       Right s -> return (read s)

save :: State -> IO State
save st =
  do writeFile saveFile (show st)
     return st

------------------------------------------------------------------------------

{-
Creating the GUI. Mainly the layout of all the widgets.
-}

main :: IO ()
main =
  do initGUI

     -- create a window
     win <- windowNew
     windowSetTitle win "Drawing"
     win `onDestroy` mainQuit

     -- the abstract widget holding the current drawing state
     drw <- newIORef clean

     -- the drawing area (canvas)
     can <- drawingAreaNew
     can `onSizeRequest`      return (Requisition sizeX sizeY)
     can `onButtonPress`      drawWithMouse click   can drw
     onMotionNotify can True (drawWithMouse move    can drw)
     can `onButtonRelease`    drawWithMouse unclick can drw

     -- the buttons
     und <- buttonNewWithLabel "Undo"
     loa <- buttonNewWithLabel "Load"
     sav <- buttonNewWithLabel "Save"
     und `onClicked` drawWith (return . undo) can drw
     loa `onClicked` drawWith load            can drw
     sav `onClicked` drawWith save            can drw

     bts <- hBoxNew False 5
     containerAdd bts und
     containerAdd bts loa
     containerAdd bts sav

     -- putting it all together
     lay <- vBoxNew False 5
     containerAdd lay can
     containerAdd lay bts

     containerAdd win lay
     widgetShowAll win
     mainGUI

------------------------------------------------------------------------------

{-
Linking the State model with the GUI. Here we decide where the arguments to
the functions in the model come from (from the IORef State and the current
position of the mouse), and what we do with their result (we write it to
the IORef State and draw lines on the screen).
-}

drawWithMouse :: (Point -> State -> State) -> DrawingArea -> IORef State -> event -> IO Bool
drawWithMouse f can drw _evt =
  do p <- widgetGetPointer can
     drawWith (return . f p) can drw
     return True

drawWith :: (State -> IO State) -> DrawingArea -> IORef State -> IO ()
drawWith f can drw =
  do -- computing and updating the state
     st <- readIORef drw
     st'@(State ls ml) <- f st
     writeIORef drw st'

     -- drawing black and red lines
     dw <- widgetGetDrawWindow can
     drawWindowClear dw
     
     norm <- gcNew dw
     sequence_ [ drawLine dw norm p q | (p,q) <- ls ]
     
     red  <- gcNewWithValues dw newGCValues{ foreground = Color 65535 0 0 }
     case ml of
       Just (p,q) -> drawLine dw red p q
       Nothing    -> return ()

------------------------------------------------------------------------------