-- The languages include needed because I wanted to use
-- (Point,Point,Point) instead of 
-- data Point3D = Point3D (Point,Point,Point) deriving ...
{-
The module YGL will contains most boilerplate
And display details.

To make things even nicer, we should separate
this file in many different parts.
Typically separate the display function.

-}
module YGL (
    -- Datas
    Point 
    , Time
    , Scalar
    , Color
    , Point3D
    , makePoint3D -- helper (x,y,z) -> Point3D
    , (-*<) -- scalar product on Point3D
    , Function3D
    -- Your world state must be an instance
    -- of the DisplayableWorld type class
    , DisplayableWorld (..)
    -- Datas related to DisplayableWorld
    , Camera (..)
    , YObject (..)
    , Box3D (..)
    , makeBox
    , hexColor
    , makeColor
    -- Datas related to user Input
    , InputMap
    , UserInput (Press,Ctrl,Alt,CtrlAlt)
    , inputMapFromList
    -- The main loop function to call
    , yMainLoop) where

import Numeric (readHex)
import Graphics.Rendering.OpenGL hiding (Color)
import Graphics.UI.GLUT hiding (Color)
import Data.IORef
import qualified Data.Map as Map
import Control.Monad (when)
import Data.Maybe (isNothing)

{-- Things start to be complex here.
- Just take the time to follow me.
--}

-- | A 1D point
type Point   = GLfloat 
-- | A Scalar value
type Scalar  = GLfloat
-- | The time type (currently its Int
type Time = Int
-- | A 3D Point mainly '(x,y,z)'
data Point3D = P (Point,Point,Point) deriving (Eq,Show,Read)
type Color = Color3 Scalar

xpoint :: Point3D -> Point
xpoint (P (x,_,_)) = x
ypoint :: Point3D -> Point
ypoint (P (_,y,_)) = y
zpoint :: Point3D -> Point
zpoint (P (_,_,z)) = z

makePoint3D :: (Point,Point,Point) -> Point3D
makePoint3D p = P p


instance Num Point3D where
    (+) (P (ax,ay,az)) (P (bx,by,bz)) = P (ax+bx,ay+by,az+bz)
    (-) (P (ax,ay,az)) (P (bx,by,bz)) = P (ax-bx,ay-by,az-bz)
    (*) (P (ax,ay,az)) (P (bx,by,bz)) = P ( ay*bz - az*by
                                , az*bx - ax*bz
                                , ax*by - ay*bx )
    abs (P (x,y,z)) = P (abs x,abs y, abs z)
    signum (P (x,y,z)) = P (signum x, signum y, signum z)
    fromInteger i = P (fromInteger i, 0, 0)

infixr 5 -*<
(-*<) :: Scalar -> Point3D -> Point3D
(-*<) s p = P (s*xpoint p, s*ypoint p, s*zpoint p)


toGLVector3 :: Point3D -> Vector3 GLfloat
toGLVector3 (P(x,y,z)) = Vector3 x y z

toGLVertex3 :: Point3D -> Vertex3 GLfloat
toGLVertex3 (P(x,y,z)) = Vertex3 x y z

toGLNormal3 :: Point3D -> Normal3 GLfloat
toGLNormal3 (P(x,y,z)) = Normal3 x y z

-- | The Box3D type represent a 3D bounding box
-- | Note if minPoint = (x,y,z) and maxPoint = (x',y',z')
-- | Then to have a non empty box you must have
-- | x<x' & y<y' & z<z'
data Box3D = Box3D {
         minPoint :: Point3D 
       , maxPoint :: Point3D
       , resolution :: Scalar }

makeBox :: (Point,Point,Point) -> (Point,Point,Point) -> Scalar -> Box3D
makeBox mini maxi res = Box3D {
      minPoint = makePoint3D mini
    , maxPoint = makePoint3D maxi
    , resolution = res  }

type Triangle3D = (Point3D,Point3D,Point3D,Color)
-- For a general purpose library we should add many other different atoms
-- corresponding to Quads for example.
data Atom = ColoredTriangle Triangle3D 
type Function3D = Point -> Point -> Maybe (Point,Color)
data YObject =   XYFunc Function3D Box3D
               | Atoms [Atom]

atoms :: YObject -> [Atom]
atoms (XYFunc f b) = getObject3DFromShapeFunction f b
atoms (Atoms atomList) = atomList

-- | We decalre the input map type we need here
-- | It is our API
type InputMap worldType = Map.Map UserInput (worldType -> worldType)
data UserInput = Press Char | Ctrl Char | Alt Char | CtrlAlt Char 
                 deriving (Eq,Ord,Show,Read)

-- | A displayable world 
class DisplayableWorld world where
    camera :: world -> Camera
    camera _ = defaultCamera 
    lights :: world -> [Light]
    lights _ = []
    objects :: world -> [YObject]
    objects _ = []
    winTitle :: world -> String
    winTitle _ = "YGL"

-- | the Camera type to know how to
-- | Transform the scene to see the right view.
data Camera = Camera {
          camPos  :: Point3D
        , camDir  :: Point3D
        , camZoom :: Scalar }

defaultCamera :: Camera
defaultCamera = Camera {
      camPos = makePoint3D (0,0,0)
    , camDir = makePoint3D (0,0,0)
    , camZoom = 1 }


-- Given a shape function and a delimited Box3D
-- return a list of Triangles to be displayed
getObject3DFromShapeFunction :: Function3D -> Box3D -> [Atom]
getObject3DFromShapeFunction shape box = do
  x <- [xmin,xmin+res..xmax]
  y <- [ymin,ymin+res..ymax]
  let 
    neighbors = [(x,y),(x+res,y),(x+res,y+res),(x,y+res)]
    -- zs are 3D points with found depth and color
    -- zs :: [ (Point,Point,Point,Maybe (Point,Color) ]
    zs = map (\(u,v) -> (u,v,shape u v)) neighbors
    -- ps are 3D opengl points + color value
    ps = zs
  -- If the point diverged too fast, don't display it
  if any (\(_,_,z) -> isNothing z) zs
  then []
  -- Draw two triangles
  --    3 - 2
  --    | / |
  --    0 - 1
  -- The order is important
  else 
    [ makeAtom (ps!!0) (ps!!2) (ps!!1)
    , makeAtom (ps!!0) (ps!!3) (ps!!2) ]
  where
    makeAtom (p0x,p0y,Just (p0z,c0)) (p1x,p1y,Just (p1z,_)) (p2x,p2y,Just (p2z,_)) =
        ColoredTriangle (makePoint3D (p0x,p0y,p0z)
                        ,makePoint3D (p1x,p1y,p1z)
                        ,makePoint3D (p2x,p2y,p2z)
                        ,c0)
    makeAtom _ _ _ = error "Somethings wrong here"

    -- some naming to make it 
    -- easier to read
    xmin = xpoint $ minPoint box
    xmax = xpoint $ maxPoint box
    ymin = ypoint $ minPoint box
    ymax = ypoint $ maxPoint box
    res = resolution box

inputMapFromList :: (DisplayableWorld world) => 
    [(UserInput,world -> world)] -> InputMap world
inputMapFromList = Map.fromList

{-- 
- We set our mainLoop function
- As you can see the code is _not_ pure 
- and not even functionnal friendly!
- But when called,
- it will look like a standard function.
--}
yMainLoop :: (DisplayableWorld worldType) =>
             InputMap worldType -- the mapping user input / world
             -> (Time -> worldType -> worldType)
             -> worldType -- the world state
             -> IO ()     -- into IO () for obvious reason
yMainLoop inputActionMap 
          worldTranformer
          world = do
  -- The boilerplate
  _ <- getArgsAndInitialize
  initialDisplayMode $= 
      [WithDepthBuffer,DoubleBuffered,RGBMode]
  _ <- createWindow $ winTitle world
  depthFunc  $= Just Less
  windowSize $= Size 500 500
  -- The state variables for the world (I know it feels BAD)
  worldRef <- newIORef world
  -- Action to call when waiting
  idleCallback $= Just (idle worldTranformer worldRef)
  -- the keyboard will update the world
  keyboardMouseCallback $= 
          Just (keyboardMouse inputActionMap worldRef)
  -- We generate one frame using the callback
  displayCallback $= display worldRef
  normalize $= Enabled
  -- Lights
  lighting $= Enabled
  ambient (Light 0) $= Color4 0 0 0 1
  diffuse (Light 0) $= Color4 0.5 0.5 0.5 1
  specular (Light 0) $= Color4 1 1 1 1
  position (Light 0) $= Vertex4 1 1 0 1
  light (Light 0) $= Enabled
  colorMaterial $= Just (Front,AmbientAndDiffuse)
  materialDiffuse Front $= Color4 0.5 0.5 0.5 1 
  materialAmbient Front $= Color4 0.5 0.5 0.5 1 
  materialSpecular Front $= Color4 0.2 0.2 0.2 1 
  materialEmission Front $= Color4 0.3 0.3 0.3 1
  materialShininess Front $= 90.0
  -- We enter the main loop
  mainLoop

-- When no user input entered do nothing
idle :: (Time -> worldType -> worldType) -> IORef worldType -> IO ()
idle worldTranformer world = do
    w <- get world
    t <- get elapsedTime
    world $= worldTranformer t w
    postRedisplay Nothing

-- Get User Input
-- both cleaner, terser and more expendable than the preceeding code
keyboardMouse :: InputMap a -> IORef a
                 -> Key -> KeyState -> Modifiers -> Position -> IO()
keyboardMouse input world key state _ _ =
    when (state == Down) $
         let 
            charFromKey (Char c) = c
            -- To replace
            charFromKey _ = '#'

            transformator = Map.lookup (Press (charFromKey key)) input 
         in 
         mayTransform transformator
    where
        mayTransform Nothing = return ()
        mayTransform (Just transform) = do
            w <- get world
            world $= transform w


-- The function that will display datas
display :: (HasGetter g, DisplayableWorld world) => 
           g world -> IO ()
display worldRef = do
    -- BEWARE UGLINESS!!!!
    -- SHOULD NEVER MODIFY worldRef HERE!!!!
    --
    -- I SAID NEVER.
    w <- get worldRef
    -- NO REALLY, NEVER!!!!
    -- If someone write a line starting by
    -- w $= ... Shoot him immediately in the head
    --          and refere to competent authorities
    let cam = camera w
    -- set the background color (dark solarized theme)
    clearColor $= Color4 0 0.1686 0.2117 1
    clear [ColorBuffer,DepthBuffer]
    -- Transformation to change the view
    loadIdentity -- reset any transformation
    -- tranlate
    translate $ toGLVector3 (camPos cam)
    -- zoom
    scale (camZoom cam) (camZoom cam) (camZoom cam)
    -- rotate
    rotate (xpoint (camDir cam)) $ Vector3 1.0 0.0 (0.0::GLfloat)
    rotate (ypoint (camDir cam)) $ Vector3 0.0 1.0 (0.0::GLfloat)
    rotate (zpoint (camDir cam)) $ Vector3 0.0 0.0 (1.0::GLfloat)
    -- Now that all transformation were made
    -- We create the object(s)
    _ <- preservingMatrix $ mapM drawObject (objects w)
    swapBuffers -- refresh screen

-- Hexa style colors
scalarFromHex :: String -> Scalar
scalarFromHex = (/256) . fst . head . readHex 

hexColor :: [Char] -> Color
hexColor ('#':rd:ru:gd:gu:bd:bu:[]) = Color3 (scalarFromHex (rd:ru:[]))
                                             (scalarFromHex (gd:gu:[])) 
                                             (scalarFromHex (bd:bu:[]))
hexColor ('#':r:g:b:[]) = hexColor ('#':r:r:g:g:b:b:[])
hexColor _ = error "Bad color!!!!"

makeColor :: Scalar -> Scalar -> Scalar -> Color
makeColor x y z = Color3 x y z
---

-- drawObject :: (YObject obj) => obj -> IO()
drawObject :: YObject -> IO()
drawObject shape = do
  -- We will print only Triangles
  renderPrimitive Triangles $ do
    -- solarized base3 color
    -- color $ hexColor "#fdf603" 
    mapM_ drawAtom (atoms shape)

-- simply draw an Atom
drawAtom :: Atom -> IO ()
drawAtom atom@(ColoredTriangle (p0,p1,p2,c)) = do
    color c
    normal $ toGLNormal3 (getNormal atom)
    vertex $ toGLVertex3 p0
    vertex $ toGLVertex3 p1
    vertex $ toGLVertex3 p2

-- get the normal vector of an Atom
getNormal :: Atom -> Point3D
getNormal (ColoredTriangle (p0,p1,p2,_)) = (p1 - p0) * (p2 - p0)