125 lines
4.5 KiB
Haskell
125 lines
4.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
|
|
module Main where
|
|
|
|
import Codec.Picture.Png
|
|
import Codec.Picture.Types
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import Data.Vector.Storable hiding ((++),map, foldl, filter, foldl1)
|
|
import Linear (V3(..))
|
|
import Data.Word (Word8)
|
|
import Data.Functor
|
|
import Data.Maybe
|
|
import Data.Traversable
|
|
import Control.Parallel.Strategies
|
|
import Control.Monad.Trans
|
|
import Control.Monad.Trans.Either
|
|
import Control.DeepSeq
|
|
import System.Environment
|
|
import System.FilePath.Posix
|
|
|
|
import Scene.Parser
|
|
import Scene.Renderer
|
|
import Scene.Types
|
|
|
|
import Debug.Trace
|
|
|
|
findCamera :: [ObjectParser] -> Either String Camera
|
|
findCamera [] = Left "No camera found"
|
|
findCamera (a:as) = case a of
|
|
OpC c -> return c
|
|
_ -> findCamera as
|
|
|
|
findDepth :: [ObjectParser] -> Either String RecursionDepth
|
|
findDepth [] = Left "No recursion depth defined"
|
|
findDepth (a:as) = case a of
|
|
OpR r -> return r
|
|
_ -> findDepth as
|
|
|
|
findAmbience :: [ObjectParser] -> Either String Ambience
|
|
findAmbience [] = Left "No ambience light defined"
|
|
findAmbience (a:as) = case a of
|
|
OpA am -> return am
|
|
_ -> findAmbience as
|
|
|
|
findBackground :: [ObjectParser] -> Either String Background
|
|
findBackground [] = Left "No background color defined"
|
|
findBackground (a:as) = case a of
|
|
OpB b -> return b
|
|
_ -> findBackground as
|
|
|
|
filterLights :: [ObjectParser] -> [Light]
|
|
filterLights [] = []
|
|
filterLights (a:as) = case a of
|
|
OpL l -> l:filterLights as
|
|
_ -> filterLights as
|
|
|
|
filterObjects :: [ObjectParser] -> [Collidable]
|
|
filterObjects [] = []
|
|
filterObjects (a:as) = case a of
|
|
OpS s -> S s:filterObjects as
|
|
OpI m -> M m:filterObjects as
|
|
OpP p -> P p:filterObjects as
|
|
_ -> filterObjects as
|
|
|
|
validateAndParseScene :: B8.ByteString -> FilePath -> EitherT String IO Scene
|
|
validateAndParseScene f p = do
|
|
obs <- hoistEither $ parseScene f
|
|
obs' <- initializeMeshes p obs
|
|
cam <- hoistEither $ findCamera obs'
|
|
depth <- hoistEither $ findDepth obs'
|
|
amb <- hoistEither $ findAmbience obs'
|
|
back <- hoistEither $ findBackground obs'
|
|
lights <- return $ filterLights obs'
|
|
objects <- return $ filterObjects obs'
|
|
return $ Scene
|
|
{ ambientLight = amb
|
|
, sceneCamera = cam
|
|
, sceneRecursions = depth
|
|
, sceneBackground = back
|
|
, sceneLights = lights
|
|
, sceneObjects = objects
|
|
}
|
|
|
|
initializeMeshes :: FilePath -> [ObjectParser] -> EitherT String IO [ObjectParser]
|
|
initializeMeshes p = traverse (initializeMeshes' p)
|
|
where
|
|
initializeMeshes' :: FilePath -> ObjectParser -> EitherT String IO ObjectParser
|
|
initializeMeshes' p (OpM (UIMesh f s m)) =
|
|
let filename = p </> (B8.unpack f) in
|
|
do
|
|
d <- lift $ B.readFile filename
|
|
lift $ print filename
|
|
mesh <- hoistEither $ parseMesh s m d
|
|
return mesh
|
|
initializeMeshes' _ a = return a
|
|
|
|
|
|
instance NFData PixelRGB8
|
|
where
|
|
rnf (PixelRGB8 r g b) = r `seq` g `seq` b `seq` ()
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
case args of
|
|
[] -> putStrLn "please specify a scene to render"
|
|
(a:_) -> do
|
|
putStrLn $ "reading and parsing "++ show a
|
|
!f <- B.readFile a
|
|
r <- runEitherT $ validateAndParseScene f (dropFileName a)
|
|
print r
|
|
case r of
|
|
Left error -> putStrLn $ "Error: " ++ error
|
|
Right s -> do
|
|
putStrLn "redering..."
|
|
let (w,h) = (width . sceneCamera $ s, height . sceneCamera $ s)
|
|
imvec = fromList ((render w h s <$> [0..w*h-1]) `using` parListChunk w rseq)
|
|
im = generateImage (v3ToPixel w imvec) w h
|
|
writePng "out.png" im
|
|
|
|
v3ToPixel :: Int -> Vector (V3 Word8) -> Int -> Int -> PixelRGB8
|
|
v3ToPixel w vec x y = PixelRGB8 r g b
|
|
where
|
|
V3 r g b = vec ! (y*w+x)
|