module Main (main) where

--------------------------------------------------------------------------------
--
-- Graphische Darstellung von Lindenmayer-Systemen
--
-- Tastenbelegungen im Hauptfenster:
-- Links, Rechts              -> Ansicht um Up-Achse drehen
-- Oben, Unten                -> Ansicht um Head-Achse drehen
-- Strg + Pfeiltaste          -> Ansicht verschieben
-- '+', '-'                   -> Ableitungsschritt ändern
-- 'I', 'O'                   -> Hinein- bzw. Hinauszoomen
--
--------------------------------------------------------------------------------

import Graphics.UI.GLUT hiding (initState)
import Graphics.Rendering.OpenGL

import LSystem
import Turtle

import Utilities

import Data.Char (toUpper)
import Data.IORef

import KochLSystem     -- Koch'sche Schneeflocke, Präfix: "koch"
import IslandLSystem   -- Aufgabe 1.a, Präfix: "island"
import TreeLSystem     -- Aufgabe 1.b, Präfix: "tree"
import ConiferLSystem  -- Aufgabe 1.c, Präfix: "conifer"

-- Präfix für andere Beispiele ändern
global_Interpretation = kochInterpretation
global_LSystem = kochLSystem


-- Aktueller Zustand des Systems
data State = State {
  derivationIndex :: Int,

  viewPhi :: Double,
  viewTheta :: Double,
  zoom :: Double,
  pan :: (Double, Double),
  viewRatio :: Double,
  renderingRequired :: Bool,

  currentLineWidth :: Double,
  lineWidthStack :: [Double]
  }


initState = State {
  derivationIndex = 0,

  viewPhi = 0,
  viewTheta = 0,
  zoom = 1,
  pan = (0,0),
  viewRatio =
    (fromIntegral global_windowSizeX) / (fromIntegral global_windowSizeY),
  renderingRequired = True,

  currentLineWidth = 1,
  lineWidthStack = []
  }


-- globale Werte
global_windowTitle = "Lindenmayer-Systeme"
global_windowSizeX = 400
global_windowSizeY = 400
global_pixelWidth = 2 / (fromIntegral global_windowSizeX)



-------------------------------------------------------------------------------
-- MAIN
-------------------------------------------------------------------------------


main = do
  getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer, DoubleBuffered]

  state <- newIORef initState

  depthFunc $= Just Less
  createWindow global_windowTitle
  windowSize $= Size global_windowSizeX global_windowSizeY

  lighting $= Enabled
  normalize $= Enabled
  depthFunc $= Just Less

  displayCallback $= display state
  keyboardMouseCallback $= Just (keyboard state)
  reshapeCallback $= Just (reshape state)

  mainLoop



-- Hauptzeichenfunktion --------------------------------------------------------


display state = do
  curState <- get state
  let
    z = realToReal $ zoom curState
    (panX, panY) = pan curState
    rat = viewRatio curState

  projection (-z) (z) (-z / realToReal rat) (z / realToReal rat) (-1000) (1000)

  clearColor $= Color4 0 0 0 0
  clear [ColorBuffer, DepthBuffer]

  loadIdentity

  position (Light 0) $= Vertex4 (-1) (1) 10 1
  ambient (Light 0) $= Color4 1 1 1 1
  diffuse (Light 0) $= Color4 1 1 1 1
  specular (Light 0) $= Color4 1 1 1 1
  light (Light 0) $= Enabled

  cCyanMaterial

  translate $ Vector3 (doubleToGLfloat panX) (doubleToGLfloat panY) 0

  rotate (doubleToGLfloat $ negate $ viewTheta curState) $ Vector3 1 0 0
  rotate (doubleToGLfloat $ viewPhi curState) $ Vector3 0 0 1

  let i = derivationIndex curState

  if (renderingRequired curState)
    then defineList (DisplayList 1) CompileAndExecute $ do
      sequence_ $ (render state $
        interpretations global_Interpretation $
        derivations global_LSystem) !! i

    else do
      callList (DisplayList 1)

  windowTitle $= global_windowTitle ++ " (n=" ++ (show i) ++ ")"
  state $= curState { renderingRequired = False }
  swapBuffers



-- Fensterskalierung -----------------------------------------------------------


reshape state s = do
  curState <- get state
  let (Size x y) = s
  state $= curState { viewRatio = (fromIntegral x) / (fromIntegral y) }
  viewport $= (Position 0 0, s)



-- Tastatur-Ereignisverarbeitung -----------------------------------------------


keyboard state (Char key) Down _ _ = do
  curState <- get state
  let
    i = derivationIndex curState
    z = zoom curState

  case toUpper key of
    'I' -> do
      state $= curState { zoom = z / 1.05 }
      postRedisplay Nothing
    'O' -> do
      state $= curState { zoom = z * 1.05 }
      postRedisplay Nothing
    '+' -> do
      state $= curState { derivationIndex = i+1, renderingRequired = True }
      postRedisplay Nothing
    '-' -> do
      state $= curState { derivationIndex = if (i==0) then 0 else i-1,
        renderingRequired = True }
      postRedisplay Nothing
    _ -> return ()

keyboard state (SpecialKey specialKey) Down mod _ = do
  curState <- get state
  let
    phi = viewPhi curState
    theta = viewTheta curState
    ctrlPressed = ctrl mod == Down
    z = zoom curState
    (x,y) = pan curState

  case specialKey of
    KeyLeft -> do
      if ctrlPressed
        then do
          state $= curState { pan = (x-0.05*z, y) }
        else do
          state $= curState { viewPhi = if phi < 0 then phi+355 else phi-5 }
      postRedisplay Nothing
    KeyRight -> do
      if ctrlPressed
        then do
          state $= curState { pan = (x+0.05*z, y) }
        else do
          state $= curState { viewPhi = if phi >= 360 then phi-355 else phi+5 }
      postRedisplay Nothing

    KeyDown -> do
      if ctrlPressed
        then do
          state $= curState { pan = (x, y-0.05*z) }
        else do
          state $= curState
            { viewTheta = if theta < 0 then theta+355 else theta-5 }
      postRedisplay Nothing
    KeyUp -> do
      if ctrlPressed
        then do
          state $= curState { pan = (x, y+0.05*z) }
        else do
          state $= curState
            { viewTheta = if theta >= 360 then theta-355 else theta+5 }
      postRedisplay Nothing
    _ -> return ()

keyboard _ _ _ _ _ = return ()



-- Grafik-Berechnung -----------------------------------------------------------


-- Drehung um alpha Grad um die Up-Achse
rotateU :: GLfloat -> IO ()
rotateU alpha = rotate alpha $ Vector3 0 0 (1::GLfloat)

turnLeft = rotateU
turnRight = rotateU . negate
turnAround = rotateU 180


-- Drehung um alpha Grad um die Left-Achse
rotateL :: GLfloat -> IO ()
rotateL alpha = rotate alpha $ Vector3 0 (1) (0::GLfloat)

pitchDown = rotateL
pitchUp = rotateL . negate


-- Drehung um alpha Grad um die Heading-Achse
rotateH :: GLfloat -> IO ()
rotateH alpha = rotate alpha $ Vector3 (-1) 0 (0::GLfloat)

rollLeft = rotateH
rollRight = rotateH . negate


-- forward state length draw
--
-- Turtle length Pixel vorwärts bewegen. Ist draw = True wird ein Zylinder
-- der Länge length im Raum gezeichnet, sonst nur die Position verändert.
--
forward :: IORef State -> GLfloat -> Bool -> IO ()
forward state length draw = do
  curState <- get state

  let
    len = global_pixelWidth * length
    wid = global_pixelWidth * realToReal (currentLineWidth curState)
    r = wid/2
    d = global_pixelWidth

  if draw
    then do
      if len/=0 then drawCylinder r r len 32 else return ()
      translate $ Vector3 len 0 0
      renderObject Solid $
        Sphere' (realToReal $ r + (global_pixelWidth/10)) 8 8
    else do
      translate $ Vector3 len 0 0


-- Liste von TurtleModul-Sequenzen in Zeichenfunktionen übersetzen
render :: IORef State -> [ [LPrim TurtleModule] ] -> [ [IO ()] ]
render state = map render'
  where
    render' = map r
    r (LStack s) = do
      curState <- get state
      let
        oldStack = lineWidthStack curState
        wid = currentLineWidth curState
      state $= curState { lineWidthStack = wid:oldStack }
      preservingMatrix $ sequence_ $ render' s
      state $= curState { lineWidthStack = oldStack }

    r (LPrim p) = case p of
      TDraw len         -> forward state (realToReal len) True
      TMove len         -> forward state (realToReal len) False

      TTurnLeft alpha   -> turnLeft $ realToReal alpha
      TTurnRight alpha  -> turnRight $ realToReal alpha
      TTurnAround       -> turnAround

      TPitchDown alpha  -> pitchDown $ realToReal alpha
      TPitchUp alpha    -> pitchUp $ realToReal alpha

      TRollLeft alpha   -> rollLeft $ realToReal alpha
      TRollRight alpha  -> rollRight $ realToReal alpha

      TSetLineWidth wid -> do
        curState <- get state
        state $= curState { currentLineWidth = realToReal wid }


-- Zeichnet Zylinder in der y-z-Ebene (= Turtle-Rücken-Ebene)
drawCylinder ry rz len n = do
  renderPrimitive QuadStrip (vertexesN $ interleave fullE fullE')
  where
    fullE' = map (\(x,y,z) -> (x+len,y,z)) fullE
    fullE = [(0,y,z::GLfloat) | i<-[0..n],
      let a = 2 * pi * i/n, let y = -ry * cos a, let z = rz * sin a]


-- Gibt eine Liste von Punkten in Form von vertex-Befehlen wieder. Die Liste
-- wird als QuadStrip interpretiert und für jedes Rechteck der entsprechende
-- Normalenvektor eingefügt
vertexesN :: (VertexComponent a, NormalComponent a, Num a) => [(a,a,a)] -> IO ()
vertexesN (a:b:c:d:rs) = do
  normal $ norm a b c
  vertex $ vert a
  vertex $ vert b
  vertexesN (c:d:rs)
  where
    vert = \(x,y,z) -> Vertex3 x y z
    norm = \v1 v2 v3 -> let (x, y, z) = (v2-v1) * (v3-v1) in Normal3 x y z
-- Restliche Punkte einfach in Vertexes umwandeln
vertexesN rs = sequence_ $ map (\(x,y,z) -> vertex (Vertex3 x y z)) rs