module Language.Mecha.Assembly
  ( Asm
  , Part
  , part
  , place
  , view
  ) where

import Control.Monad
import Control.Monad.Trans
import qualified Graphics.Rendering.OpenGL as GL

import Language.Mecha.Mesh
import Language.Mecha.OpenGL
import Language.Mecha.Solid
import Language.Mecha.Types
import Language.Mecha.Viewer


data AsmDB = AsmDB
  { asmColor      :: Color
  , asmModel      :: IO ()
  }

-- | The Asm holds all the parts and sub-assemblies.
data Asm a = Asm (AsmDB -> IO (a, AsmDB))

instance Monad Asm where
  return a = Asm (\ s -> return (a, s))
  (Asm f1) >>= f2 = Asm f3
    where
    f3 s = do
      (a, s) <- f1 s
      let Asm f4 = f2 a
      f4 s

instance MonadIO Asm where
  liftIO io = Asm f
    where
    f s = do
      a <- io
      return (a, s)

get :: Asm AsmDB
get = Asm (\ s -> return (s, s))

put :: AsmDB -> Asm ()
put s = Asm (\ _ -> return ((), s))

instance Colorable (Asm a) where
  color c a = do
    asm1 <- get
    put asm1 { asmColor = c }
    a <- a
    asm2 <- get
    put asm2 { asmColor = asmColor asm1 }
    return a

transform :: IO () -> Asm a -> Asm a
transform action (Asm f) = do
  asm1 <- get
  (a, asm2) <- liftIO $ f AsmDB
    { asmColor = asmColor asm1
    , asmModel = return ()
    }
  put asm1 { asmModel = asmModel asm1 >> GL.preservingMatrix (action >> asmModel asm2) }
  return a

instance Moveable (Asm a) where
  move (x, y, z) = transform (translate3 x y z)
  rotate (x, y, z) angle = transform (rotate3 angle x y z)

newtype Part = Part (IO ())

-- | Define a new part.
part :: Double -> Double -> Int -> Solid -> Asm Part
part radius precision n a = return $ Part model
  where
  triangles = mesh radius precision n a
  model = GL.renderPrimitive GL.Triangles $ do
    sequence_ [ normal3 nx ny nz >> vertex3 vx vy vz | ((nx, ny, nz), (vx, vy, vz)) <- triangles ]
    
-- | Place a part in an assembly.
place :: Part -> Asm ()
place (Part a) = do
  asm <- get
  let (r, g, b) = asmColor asm
  put asm { asmModel = asmModel asm >> color3 r g b >> a }


-- | View an assembly given radius, precision, and vertex refinement level.
view :: Asm () -> IO ()
view (Asm f) = do
  ((), AsmDB _ model) <- f AsmDB
    { asmColor = (0.5, 0.5, 0.5)
    , asmModel = return ()
    }
  viewer model