import Data.Maybe (fromJust)
import Control.Monad
import System.Random
import qualified Data.Map as M hiding (filter)
import Data.Char
import Data.Word
import Data.IORef

import Paths_nymphaea (getDataFileName)

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.Cairo
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.Rendering.Cairo as Cairo
import System.Glib.Types

import MonadRandom as R
import Parser
import LSystem
import CairoExts

data PinState = NoPin
              | Pin (Double, Double) (Double, Double)

main :: IO ()
main = do
  initGUI
  dialogXml <- liftM fromJust (getDataFileName "nymphaea.glade" >>= xmlNew)

  let getWidget :: WidgetClass widget => (GObject -> widget) -> String -> IO widget
      getWidget = xmlGetWidget dialogXml

  windowMain <- getWidget castToWindow "windowMain"
  windowMain `onDestroy` mainQuit

  windowDraw <- getWidget castToWindow "windowDraw"

  -- spinButtons for position and line properties
  sbLW <- getWidget castToSpinButton "spinbuttonLW"
  sbLL <- getWidget castToSpinButton "spinbuttonLL"

  fgPick <- getWidget castToColorButton "foregroundPicker"
  colorButtonSetColor fgPick (Color 0 0xffff 0x5c00)
  colorButtonSetAlpha fgPick 0x5c00
  bgPick <- getWidget castToColorButton "backgroundPicker"
  colorButtonSetColor bgPick (Color 0 0 0)

  sbI <- getWidget castToSpinButton  "spinbuttonIterations"
  sbA <- getWidget castToSpinButton  "spinbuttonAngle"
  txA <- getWidget castToTextView    "textviewAxiom"
  txP <- getWidget castToTextView    "textviewProductions"

  btDraw <- getWidget castToButton "buttonDraw"
  drawingArea <- getWidget castToDrawingArea "drawingarea1"

  {- State references -}

  -- Picture of the LSystem, if any. This only gets drawn when the window is exposed.
  pixmapRef <- newIORef Nothing
  -- We keep track of whether the user has resized the window since we last made a
  -- new image, to avoid constructing too many pixmaps.
  resizedRef <- newIORef False
  -- Whether or not there is a pin widget to be displayed on the drawing area.
  pinRef <- newIORef NoPin

  -- The starting location and angle of the LSystem.
  startCoordsRef <- do newIORef (275,500)
  startAngleRef <- do newIORef pi

  {- Event handling -}

  windowDraw `on` buttonPressEvent $
    do -- Write starting coordinates
       (px,py) <- eventCoordinates
       liftIO $ do writeIORef startCoordsRef (px, py)
                   -- Add a pin widget
                   writeIORef pinRef $ Pin (px, py) (px, py)
                   -- Force an expose
                   widgetQueueDraw drawingArea
       return True

  -- When the mouse is moved, we update the pin, if any.
  widgetAddEvents windowDraw [ButtonMotionMask]
  windowDraw `on` motionNotifyEvent $
    do pin <- liftIO $ readIORef pinRef
       case pin of
          NoPin -> return False
          Pin (px,py) _ -> do (nx,ny) <- eventCoordinates
                              -- Update the pin with the new direction
                              liftIO $ do writeIORef pinRef $ Pin (px,py) (nx,ny)
                                          -- Force an expose
                                          widgetQueueDraw drawingArea
                              return True

  -- When the button is released, we possibly set the
  -- starting angle and then redraw.
  windowDraw `on` buttonReleaseEvent $
    do (u,v) <- eventCoordinates
       (x,y) <- liftIO $ readIORef startCoordsRef
       let dx = (u - x)
           dy = (v - y)
       if dx^(2::Int) + dy^(2::Int) > 10^(2::Int) -- If the mouse is off the pin.
          then liftIO $ writeIORef startAngleRef (atan2 dx dy)
          else return ()
       liftIO $
         do -- Remove the pin
            writeIORef pinRef NoPin
            -- Redraw
            buttonClicked btDraw
       return True

  -- This prevents the drawing window from being deleted when
  -- the user closes it.
  windowDraw `on` deleteEvent $
    do liftIO $ widgetHideAll windowDraw
       return True

  -- When the user resizes the window, we set a flag, so that
  -- the draw button knows to allocate a new pixmap.
  windowDraw `on` sizeAllocate $ 
    const . liftIO $ writeIORef resizedRef True

  drawingArea `on` exposeEvent $
    do r <- eventRegion
       -- Get the pixmap and pin and the drawing area.
       liftIO $ do Just pixmap <- readIORef pixmapRef
                   pin <- readIORef pinRef
                   drawWindow <- widgetGetDrawWindow drawingArea
                   -- Paint the pixmap to the drawing area and render a pin, if any.
                   renderWithSurfaceFromDrawable pixmap drawWindow $ \s ->
                     do region r
                        clip
                        setSourceSurface s 0 0
                        paint
                        renderPin pin
                   return True

  btDraw `onClicked` do
    (x,y) <- readIORef startCoordsRef
    sa <- readIORef startAngleRef
    lw <- spinButtonGetValue sbLW
    ll <- spinButtonGetValue sbLL

    fg <- colorButtonGetColor fgPick
    bg <- colorButtonGetColor bgPick
    alpha <- colorButtonGetAlpha fgPick

    iterations <- liftM round $ spinButtonGetValue  sbI
    angle      <- spinButtonGetValue  sbA
    axiomString <- textViewGetText txA
    prodString  <- textViewGetText txP

    case (parseLSystem axiomString prodString) of
      Left err -> do
        print err
      Right (ParsedLS axim prductions) -> do
        (w,h) <- windowGetSize windowDraw

        g <- newStdGen
        widgetShowNow windowDraw
        widgetShowNow drawingArea
        drawWindow <- widgetGetDrawWindow drawingArea

        {- Determine if user resized the window. If they did resize it, we need to
           allocate a new pixmap. If not, we only allocate a new pixmap if there's
           nothing in the pixmapRef. GHC's garbage collection is poor for ForeignRefs
           to large objects so we have to be careful. -}
        resized <- readIORef resizedRef
        pixmap <- if resized then pixmapNew (Just drawWindow) w h Nothing
                             else do maybePixmap <- readIORef pixmapRef
                                     case maybePixmap of
                                          Nothing -> pixmapNew (Just drawWindow) w h Nothing
                                          Just p -> return p
        -- Write the pixmap back to the reference in case it's new.
        writeIORef pixmapRef (Just pixmap)
        -- Reset the resized flag so we don't create a new pixmap every time.
        writeIORef resizedRef False

        let lsystem = result iterations (R.fromList axim,
                                         M.map (R.fromList) (M.fromList prductions))
            selection = evalRand lsystem g
            rendering = drawLSystem w h x y sa lw ll
                                    fg bg alpha
                                    iterations angle selection

        renderWithDrawable pixmap rendering
        widgetQueueDraw drawingArea -- Force an expose event.

        return ()

  widgetShowAll windowMain
  mainGUI

textViewGetText :: TextView -> IO String
textViewGetText textview = do
  buffer <- textViewGetBuffer textview
  start <- textBufferGetStartIter buffer
  end  <- textBufferGetEndIter buffer
  textBufferGetText buffer start end False

drawLSystem ::
     Int    -- ^ render width
  -> Int    -- ^ render height
  -> Double -- ^ start x
  -> Double -- ^ start y
  -> Double -- ^ start angle
  -> Double -- ^ line width
  -> Double -- ^ line length
  -> Color  -- ^ foreground colour
  -> Color  -- ^ background colour
  -> Word16 -- ^ alpha
  -> Int    -- ^ iterations
  -> Double -- ^ angle
  -> String -- ^ turtle graphics
  -> Render ()
drawLSystem _ _ x y sa linewidth lineLength
            (Color fr fg fb) (Color br bg bb) a _ angle instructions = do
    withRGBPattern (scaling br) (scaling bg) (scaling bb) $ \p -> do {setSource p; paint}
    setSourceRGBA (scaling fr) (scaling fg) (scaling fb) (scaling a)
    setLineWidth linewidth
    translate x y
    rotate (-sa)
    moveTo 0 0
    renderLSystem lineLength angle instructions
        where scaling z = fromIntegral z / 2^(16::Int)

renderLSystem :: Double -> Double -> String -> Render ()
renderLSystem lineLength angle lsystem = renderLSystem' [] lsystem
  where
    renderLSystem' _ [] = return ()
    renderLSystem' ps ('F':rs) = do relLineTo 0 lineLength
                                    (x,y) <- getCurrentPoint
                                    stroke
                                    moveTo x y
                                    renderLSystem' ps rs
    renderLSystem' ps ('G':rs) = do relMoveTo 0 lineLength
                                    renderLSystem' ps rs
    renderLSystem' ps ('+':rs) = do rotate ( angle * pi / 180)
                                    renderLSystem' ps rs
    renderLSystem' ps ('-':rs) = do rotate (-angle * pi / 180)
                                    renderLSystem' ps rs
    renderLSystem' ps ('|':rs) = do rotate pi
                                    renderLSystem' ps rs
    renderLSystem' ps ('[':rs) = do save
                                    p <- getCurrentPoint
                                    renderLSystem' (p:ps) rs
    renderLSystem' ((x,y):ps) (']':rs) = do restore
                                            moveTo x y
                                            renderLSystem' ps rs
    renderLSystem' ps (r:rs) | isAlpha r = renderLSystem' ps rs
                             | otherwise = error $
                               "renderLSystem: unknown operator " ++ show r

{-
clearSurface :: Int -> Int -> Render ()
clearSurface width height = do
  save
  rectangle 0 0 (realToFrac width) (realToFrac height)
  setSourceRGB 1 1 1
  setOperator OperatorSource
  Cairo.fill
  restore
-}

renderPin :: PinState -> Render ()
renderPin NoPin = return ()
renderPin (Pin (x,y) (x',y')) = do
    renderPinCircle x y
    if (x - x')^(2::Int) + (y - y')^(2::Int) > 10^(2::Int)
        then renderPinVector x y (atan2 (x' - x) (y' - y))
        else return ()
    where
        renderPinCircle m n = do
            newPath -- main circle
            withRadialPattern (m-3) (n-3) 0 m n 10   $ \p -> do
                patternAddColorStopRGBA p 0  0.5 0.75 1 0.7
                patternAddColorStopRGBA p 1  0.00 0.25 1 0.5
                setSource p
                arc m n 10 0 (2 * pi)
                fillPreserve

            -- stroke to improve visibility with different backgrounds
            setSourceRGBA 0.3 0.3 0.3 0.75
            setLineWidth 1
            stroke

            newPath -- little gleam to make it look round
            setSourceRGBA 1 1 1 0.5
            arc (x-3) (y-3) 3 0 (2 * pi)
            fillPreserve

        renderPinVector m n a = do
            translate m n
            rotate (-a)
            newPath
            moveTo 0 0
            lineTo 2 0
            lineTo 0 25
            lineTo (-2) 0
            lineTo 0 0
            setSourceRGBA 0 0 0.25 0.75
            fillPreserve
            -- stroke is necessary for dark backgrounds
            setSourceRGBA 1 1 1 0.50
            setLineWidth 1
            stroke