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 ()
}
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 ())
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 :: 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 :: Asm () -> IO ()
view (Asm f) = do
((), AsmDB _ model) <- f AsmDB
{ asmColor = (0.5, 0.5, 0.5)
, asmModel = return ()
}
viewer model