--  SGdemo; a demonstration of the SG library
--  Copyright (C) 2009, Neil Brown
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.


-- | This program serves as a demonstration of the functions of the SG library
-- (to be found on Hackage:
-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/SG>)) by
-- visualising it with OpenGL.  It also serves as a sort of informal test
-- suite for the SG library.
--
-- The demonstration has a persistent state of placed shapes, lines and points,
-- which you can interact with.
--
-- There are four different modes of operation:
--
-- * Place shape (press 's').  Your cursor will shown you the shape to be placed.
--  You can alter the shape type by scrolling your mouse-wheel (for those without
-- mouse wheels, the up and down cursor keys can be used).  Intersections with
-- lines are shown by black crosses.  If you intersect another shape, black
-- lines will indicate the results of the overlap function, drawn from the centre
-- of each shape.
-- 
-- * Place line (press 'l').  At first you have a cross cursor.  You can left-click
-- to place the start of the line there.  Then, your cursor shows a prospective
-- line from the start point.  Intersections with shapes are shown with black crosses.
-- A purple line will be drawn from each point to the line, indicating the shortest
-- path from the line to each point.  Intersections with other lines are shown with
-- a black circle, and a blue line indicates the output of the reflectAgainstIfNeeded2
-- function, reflecting the prospective line against the pre-existing-line-as-surface-normal.
-- 
-- * Place point (press 'p').  Your cursor becomes a dashed circle, and left-clicking
-- will place a point there permanently.  Points are mainly useful when you later
-- switch to line mode.
-- 
-- * Rotate (press 'r').  Your cursor indicates a straight line from the centre.
--  If you left-click, that line will become the new upwards vertical, and everything
-- in the world will be rotated to match.
--
-- If in doubt, take a look at the code -- that's what it's there for!
module Main (main) where

import Data.SG

import Control.Arrow
import Control.Monad
import Data.IORef
import Data.Maybe
import Graphics.Rendering.OpenGL hiding (Polygon, multMatrix)
import Graphics.UI.GLUT hiding (cursor, Polygon, Solid, multMatrix)
import qualified Graphics.Rendering.OpenGL as GL
import Prelude hiding (lines)

-- Define our own versions of the SG types using the openGL double type:
type Point2 = Point2' GLdouble
type Rel2 = Rel2' GLdouble
type Line2 = Line2' GLdouble
type Shape = Shape' GLdouble

-- Allow for easy conversion from a Point2 type into an openGL 2D vertex:
instance IsomorphicVectors Point2' Vertex2 where
  iso (Point2 (x, y)) = Vertex2 x y

-- Helper function for drawing a point as an openGL vertex
vertex' :: Point2 -> IO ()
vertex' v = vertex (iso v :: Vertex2 GLdouble)

-- Draws a cross at the given point:
drawCross, drawSmallCircle :: Point2 -> IO ()
drawCross p = renderPrimitive Lines $ do
  -- First line:
  vertex' $ p `plusDir` makeRel2 (-0.01, 0.01) 
  vertex' $ p `plusDir` makeRel2 (0.01, -0.01)
  -- Second line:
  vertex' $ p `plusDir` makeRel2 (0.01, 0.01)
  vertex' $ p `plusDir` makeRel2 (-0.01, -0.01)
drawSmallCircle p = renderPrimitive GL.LineStrip $ drawCircle (p, 0.01)

-- Just draws the points; you choose the primitive outside!
-- Draws the first point at the end again (effectively).
drawCircle :: (Point2, GLdouble) -> IO ()
drawCircle (c, r) = mapM_ vertex' ps
  where
    ps = map (c `plusDir`) $ regularPoints 32 r
    
-- Includes the first point twice, effectively.  Gives back N points spaced equally
-- around the origin with the given radius.  So a low number (e.g. 3) will serve
-- as a regular polygon; higher numbers begin to approximate a circle.
regularPoints :: Integer -> GLdouble -> [Rel2]
regularPoints numPoints r
  = reverse antiClockwisePoints -- We need clockwise points for polygons
  where
    angleToDir t = scaleRel r $ makeRel2 (cos t, sin t)
    
    antiClockwisePoints = map angleToDir angles
    -- Equally spaced points, starting at 90 degrees (straight-up) and going all
    -- the way around.:
    angles = [(2*pi * (t / fromInteger numPoints)) + (pi/2)
             | t <- [0 .. fromInteger numPoints]]

-- We draw shapes empty when considering placing them, and solid when placed:
data DrawAs = Solid | WireFrame

drawShape :: DrawAs -> Shape -> IO ()
drawShape Solid (Circle c r)
   = renderPrimitive GL.TriangleFan $ vertex' c >> drawCircle (c, r)
drawShape WireFrame (Circle c r)
   = renderPrimitive GL.LineStrip $ drawCircle (c, r)
drawShape Solid s = renderPrimitive GL.Polygon $ mapM_ vertex' $ shapePoints s
drawShape WireFrame s = renderPrimitive GL.LineLoop $ mapM_ vertex' $ shapePoints s

-- Draws a line, with a cross at the start:
drawLine, drawLineNoCross :: Line2 -> IO ()
drawLine l = drawCross (getLineStart l) >> drawLineNoCross l
drawLineNoCross l = renderPrimitive Lines $ do
  vertex' (getLineStart l)
  vertex' (getLineEnd l)

-- Current mode we are in:
data Mode = PlaceShape Integer | PlaceLine (Maybe Point2) | PlacePoint | Rotate
  deriving (Show)

-- Makes a shape.  Pass numbers in the range 2 or higher, where 2 is a circle:
makeShape :: Integer -> Point2 -> Shape
makeShape 2 p = Circle p 0.03
makeShape 4 p = Rectangle p (0.05, 0.03)
makeShape n p = Polygon p $ init $ regularPoints n 0.04

data WorldState = WorldState
  { shapes :: [Shape]
  , lines :: [Line2]
  , points :: [Point2]
  , cursor :: Point2
  , curMode :: Mode
  }
  deriving (Show)

rotateWorld :: GLdouble -> WorldState -> WorldState
rotateWorld a w = w
  { shapes = [(rotateShape a s) {shapeCentre = rot (shapeCentre s)}
             | s <- shapes w]
  , lines = [uncurry makeLine $ rot *** rot $ getLineVecs l
            | l <- lines w]
  , points = map rot $ points w
  }
  where
    rot :: (IsomorphicVectors Pair p, IsomorphicVectors p Pair) => p GLdouble -> p GLdouble
    rot = multMatrix m
    m :: Matrix22' GLdouble
    m = rotateZaxis a

startWorld :: WorldState
startWorld = WorldState [] [] [] origin PlacePoint

-- Like mapMaybe, but keeps the original alongside the mapped version:
mapMaybe' :: (a -> Maybe b) -> [a] -> [(a, b)]
mapMaybe' f xs = [(x, y) | (x, Just y) <- map (id &&& f) xs]

-- Short for in-range-zero-to-one:
zo :: GLdouble -> Bool
zo x = 0 <= x && x <= 1

-- Given a shape, draws stuff for anything that shape might intersect with:
drawAllIntersectShape :: Shape -> WorldState -> IO ()
drawAllIntersectShape s w
-- Draw everything that might intersect with a shape: other shapes, lines
  = do let intersectionsWithLines
              = [map (`alongLine` l) -- Turn them back into points
                   $ filter zo [a,b] -- Only those in bounds
                | (l, (a, b)) <- mapMaybe' (`intersectLineShape` s) $ lines w]
       currentColor $= slColour
       sequence_ [drawCross p | p <- concat intersectionsWithLines]
       currentColor $= ssColour
       sequence_ [do drawLine (makeLine (shapeCentre s) a)
                     drawLine (makeLine (shapeCentre s') b)
                 | (s', (a, b)) <- mapMaybe' (overlap s) $ shapes w]

-- Given a line, draws stuff for anything that line might intersect with:
drawAllIntersectLine :: Line2 -> WorldState -> IO ()
drawAllIntersectLine l w
-- Draw everything that might intersect with a line: shapes, other lines (TODO points)
  = do let intersectionsWithShapes
             = [map (`alongLine` l) -- Turn them back into points
                  $ filter zo [a,b] -- Only those in bounds
               | (s, (a, b)) <- mapMaybe' (l `intersectLineShape`) $ shapes w]
       currentColor $= slColour
       sequence_ [drawCross p | p <- concat intersectionsWithShapes]
       sequence_ [do let intersectPoint = a `alongLine` l
                         reflectedDir = getLineDir l `reflectAgainstIfNeeded2` getLineDir l'
                     currentColor $= llColour
                     drawSmallCircle intersectPoint
                     currentColor $= reflectColour
                     drawLineNoCross $ makeLine intersectPoint reflectedDir
                 | (l', (a, b)) <- mapMaybe' (intersectLines2 l) $ lines w
                 , zo a -- Must be in bounds
                 , zo b -- of both lines
                 ]
       currentColor $= lpColour
       -- Draws points that are exactly on the line.  Note that this is unlikely
       -- to happen, even if it looks like it should.  Also, this is indistinguishable
       -- (at the moment) from the nearest point case below.
       sequence_ [drawCross p | p <- points w, p `isOnLine` l]
       
       sequence_ [let dist = (p `nearestDistOnLine` l)
                  in when (zo dist) $ drawLine $ (dist `alongLine` l) `lineTo` p
                 | p <- points w]


-- Draws everything in the world:
drawWorld :: WorldState -> IO ()
drawWorld w = do currentColor $= drawnColour
                 mapM_ (drawShape Solid) $ shapes w
                 mapM_ drawLine $ lines w
                 mapM_ (renderPrimitive GL.LineStrip . drawCircle . (id &&& const 0.01)) $ points w
                 currentColor $= draftColour
                 -- Draw cursor according to current mode (e.g. shapes)
                 case (curMode w) of
                   PlaceShape n -> do let s = makeShape n (cursor w)
                                      drawShape WireFrame s
                                      currentColor $= Color4 0.2 0.2 0.5 0
                                      drawAllIntersectShape s w
                   PlaceLine (Just p) -> do let l = cursor w `lineFrom` p
                                            drawLine l
                                            currentColor $= Color4 0.2 0.2 0.5 0
                                            drawAllIntersectLine l w
                   PlaceLine Nothing -> drawCross (cursor w)
                   Rotate -> drawLineNoCross $ cursor w `lineFrom` origin
                   -- All other modes:
                   -- Deliberately leave gaps in cursor by drawing as lines:
                   _ -> renderPrimitive GL.Lines $ drawCircle (cursor w, 0.02)

                 currentColor $= textColour
                 drawStatusText (text w)

text :: WorldState -> [String]
text w = (case curMode w of
  PlaceShape n -> ["SHAPE: " ++ shapeName n
                  ,"Mousewheel: change shape"
                  ,"Left click: place shape"]
  PlaceLine Nothing -> ["LINE", "Left click: place start"]
  PlaceLine (Just _) -> ["LINE", "Left click: place end"]
  PlacePoint -> ["POINT", "Left click: place point"]
  Rotate -> ["ROTATE", "Left click: set new vertical"]
  ) ++ modes
  where
    shapeName 2 = "Circle"
    shapeName 3 = "Triangle"
    shapeName 4 = "Rectangle"
    shapeName n = show n ++ "-sided"

    modes = ["s: Shape Mode"
            ,"l: Line Mode"
            ,"p: Point Mode"
            ,"r: Rotate Mode"
            ]

-- Draws the given status text.
drawStatusText :: [String] -> IO ()
drawStatusText strLines = preservingMatrix $ do
       matrixMode $= Modelview 0
       loadIdentity
       let toDouble = fromInteger . toInteger
       let targetWidth = 0.4
       origWidth <- liftM (maximum . map toDouble) $ mapM (stringWidth Roman) strLines
       let sc = targetWidth / origWidth
       lineWidth $= 2
--       lineSmooth $= Enabled
       sequence_ [ do translate $ Vector3 0.1 (0.2 + (150 * sc * n)) 0
                      scale sc sc (1 :: GLdouble)
                      renderString Roman s
                      loadIdentity
                 | (n, s) <- zip [0..] $ reverse strLines]

draftColour, drawnColour, reflectColour, slColour, ssColour, llColour, lpColour,
  textColour :: Color4 GLfloat
textColour = Color4 0 0 0.5 0
-- For things relating to the cursor:
draftColour = Color4 1 0 0 0
-- For things now in the world properly:
drawnColour = Color4 1 0.25 0.5 0
-- For reflective lines:
reflectColour = Color4 0 0 1 0
-- For shapes intersecting lines:
slColour = Color4 0 0 0 0
-- For shapes intersecting shapes:
ssColour = slColour
-- For lines intersecting lines:
llColour = slColour
-- For lines nearest to points:
lpColour = Color4 0.75 0.25 0.75 0

processWorld :: Key -> WorldState -> WorldState
processWorld k ws = case (k, curMode ws) of
  -- Mode changes:
  (Char 'l', _) -> ws { curMode = PlaceLine Nothing }
  (Char 'p', _) -> ws { curMode = PlacePoint }
  (Char 's', _) -> ws { curMode = PlaceShape 2}
  (Char 'r', _) -> ws { curMode = Rotate}

  -- Point placement:
  (MouseButton LeftButton, PlacePoint)
    -> ws { points = cursor ws : points ws }

  -- Shape placement:
  (MouseButton WheelUp, PlaceShape 2)
    -> ws
  (MouseButton WheelUp, PlaceShape n)
    -> ws { curMode = PlaceShape $ pred n }
  (MouseButton WheelDown, PlaceShape n)
    -> ws { curMode = PlaceShape $ succ n }

  (SpecialKey KeyUp, PlaceShape 2)
    -> ws
  (SpecialKey KeyUp, PlaceShape n)
    -> ws { curMode = PlaceShape $ pred n }
  (SpecialKey KeyDown, PlaceShape n)
    -> ws { curMode = PlaceShape $ succ n }

  (MouseButton LeftButton, PlaceShape n)
    -> ws { shapes = makeShape n (cursor ws) : shapes ws }

  -- Line placement:
  (MouseButton LeftButton, PlaceLine Nothing)
    -> ws { curMode = PlaceLine $ Just $ cursor ws }
  (MouseButton LeftButton, PlaceLine (Just p))
    -> ws { curMode = PlaceLine Nothing
          , lines = (cursor ws `lineFrom` p) : lines ws }

  -- Rotation:
  (MouseButton LeftButton, Rotate)
    -> rotateWorld (negate (toAngle (cursor ws `fromPt` origin)) + (pi/2)) ws

  -- Anything else:
  _ -> ws

glRunAs2D :: IO () -> IO ()
glRunAs2D draw = do
  matrixMode $= Modelview 0
  loadIdentity

  matrixMode $= Projection
  loadIdentity

  ortho (-0.5) 0.5 (-0.5) 0.5 (-1000) 1000

  preservingMatrix draw

main :: IO ()
main = do
  world <- newIORef startWorld

  -- Create the window:
  initialWindowSize $= Size 500 500
  getArgsAndInitialize
  initialDisplayMode $= [DoubleBuffered]
  _window <- createWindow "SGdemo"

  -- Register callbacks:
  let translate :: Position -> IO Point2
      translate (Position x y)
        = do (_, Size w h) <- get viewport
             return (Point2 ( (conv x / conv w) - 0.5
                            , negate (conv y / conv h) + 0.5))

      conv :: (Integral a, Num b) => a -> b
      conv = fromInteger . toInteger
      moveCursor p = do w <- readIORef world
                        writeIORef world $ w { cursor = p }

  passiveMotionCallback $= Just (\pos ->
    translate pos >>= moveCursor >> postRedisplay Nothing)

  keyboardMouseCallback $= Just (\k st _ pos ->
    do translate pos >>= moveCursor
       when (st == Down) $
         modifyIORef world $ processWorld k
       postRedisplay Nothing)

  displayCallback $= (glRunAs2D $ do
      clearColor $= Color4 1 1 1 1
      lineWidth $= 1
      lineSmooth $= Disabled
      clear [ColorBuffer, DepthBuffer]
      readIORef world >>= drawWorld
      flush
      swapBuffers)

  mainLoop