diff options
author | Josh Rahm <joshuarahm@gmail.com> | 2022-12-03 17:37:59 -0700 |
---|---|---|
committer | Josh Rahm <joshuarahm@gmail.com> | 2022-12-03 17:37:59 -0700 |
commit | ba59711a51b4fee34009b1fe6afdce9ef8e60ae0 (patch) | |
tree | 7274bd2c9007abe08c8db7cea9e55babfd041125 /Graphics/Glyph/ObjLoader.hs | |
parent | 601f77922490888c3ae9986674e332a5192008ec (diff) | |
download | terralloc-ba59711a51b4fee34009b1fe6afdce9ef8e60ae0.tar.gz terralloc-ba59711a51b4fee34009b1fe6afdce9ef8e60ae0.tar.bz2 terralloc-ba59711a51b4fee34009b1fe6afdce9ef8e60ae0.zip |
Diffstat (limited to 'Graphics/Glyph/ObjLoader.hs')
-rw-r--r-- | Graphics/Glyph/ObjLoader.hs | 166 |
1 files changed, 84 insertions, 82 deletions
diff --git a/Graphics/Glyph/ObjLoader.hs b/Graphics/Glyph/ObjLoader.hs index b392a26..9acaf48 100644 --- a/Graphics/Glyph/ObjLoader.hs +++ b/Graphics/Glyph/ObjLoader.hs @@ -1,37 +1,36 @@ module Graphics.Glyph.ObjLoader where -import Graphics.Glyph.BufferBuilder -import Graphics.Glyph.Util -import Debug.Trace - -import Data.List.Split import Control.Monad -import Data.Either import Data.Array -import System.IO -import qualified Data.Map as M - import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C +import Data.Either +import Data.List.Split +import qualified Data.Map as M +import Debug.Trace +import Graphics.Glyph.BufferBuilder +import Graphics.Glyph.Util +import System.IO data ObjectFile a = ObjectFile [ObjectStatement a] -data ObjectStatement a = - Nop | - VertexStatement (a,a,a) | - TextureStatement (a,a) | - VertexNormalStatement (a,a,a) | - UseMaterialStatement (String) | - MaterialLibraryStatement String | - FaceStatement [(Int,Int,Int)] deriving Show +data ObjectStatement a + = Nop + | VertexStatement (a, a, a) + | TextureStatement (a, a) + | VertexNormalStatement (a, a, a) + | UseMaterialStatement (String) + | MaterialLibraryStatement String + | FaceStatement [(Int, Int, Int)] + deriving (Show) foldl2 :: a -> [b] -> (a -> b -> a) -> a -foldl2 a b c = foldl c a b +foldl2 a b c = foldl c a b isNop :: ObjectStatement a -> Bool -isNop x = case x of - Nop -> True - _ -> False +isNop x = case x of + Nop -> True + _ -> False isVertex :: ObjectStatement a -> Bool isVertex (VertexStatement _) = True @@ -47,77 +46,80 @@ isTexture _ = False basicBuildObject :: (Floating b, IsModelBuilder b a) => ObjectFile b -> a () basicBuildObject (ObjectFile list) = - let fromList lst = listArray (0,length lst-1) lst in - - -- Set up the lists as arrays for fast access - let vertexList = fromList $ map (\stmt -> - case stmt of - (VertexStatement v) -> v - _ -> (0,0,0)) (filter isVertex list) in - - let normalList = fromList $ map (\stmt -> - case stmt of - (VertexNormalStatement v) -> v - _ -> (0,0,0)) (filter isNormal list) in - - let textureList = fromList $ map (\stmt -> + let fromList lst = listArray (0, length lst -1) lst + in -- Set up the lists as arrays for fast access + let vertexList = + fromList $ + map + ( \stmt -> + case stmt of + (VertexStatement v) -> v + _ -> (0, 0, 0) + ) + (filter isVertex list) + in let normalList = + fromList $ + map + ( \stmt -> case stmt of - (TextureStatement v) -> v - _ -> (0,0)) (filter isTexture list) in - - forM_ list $ \stmt -> - case stmt of - (FaceStatement arr) -> - forM_ arr $ \(a,b,c) -> do - when (c >= 0) (uncurry3 plotNormal $ normalList ! (c-1)) - when (b >= 0) (uncurry plotTexture $ textureList ! (b-1)) - when (a >= 0) (uncurry3 plotVertex3 $ vertexList ! (a-1)) - _ -> return () - + (VertexNormalStatement v) -> v + _ -> (0, 0, 0) + ) + (filter isNormal list) + in let textureList = + fromList $ + map + ( \stmt -> + case stmt of + (TextureStatement v) -> v + _ -> (0, 0) + ) + (filter isTexture list) + in forM_ list $ \stmt -> + case stmt of + (FaceStatement arr) -> + forM_ arr $ \(a, b, c) -> do + when (c >= 0) (uncurry3 plotNormal $ normalList ! (c -1)) + when (b >= 0) (uncurry plotTexture $ textureList ! (b -1)) + when (a >= 0) (uncurry3 plotVertex3 $ vertexList ! (a -1)) + _ -> return () loadObjFromBytestring :: (Read b) => L.ByteString -> ([String], ObjectFile b) loadObjFromBytestring _contents = - let contents::[L.ByteString] ; contents = C.split '\n' _contents in - let mys2n str = case str of - "" -> -1 - _ -> read str in - - let s2t s = case splitOn "/" s of - [a,b,c] -> Just (mapT3 mys2n (a,b,c)) - [a,b] -> Just (mapT3 mys2n (a,b,"")) - [a] -> Just (mapT3 mys2n (a,"","")) - _ -> Nothing in - - let compiled = - map (\(num,line) -> case words $ C.unpack line of - - [] -> Right Nop -- This is an empty line - (('#':_):_) -> Right Nop -- This is a comment, so use a 'nop' - ("o":_) -> Right Nop -- Not really of use - - ["v",x,y,z] -> Right $ VertexStatement ( (read x), (read y), (read z)) - ["vt",x,y] -> Right $ TextureStatement ( (read x), (read y)) - ["vn",x,y,z] -> Right $ VertexNormalStatement ( (read x), (read y), (read z)) - ["usemtl", mtl] -> Right $ UseMaterialStatement mtl - ["mtllib", lib] -> Right $ MaterialLibraryStatement lib - - ("f":_tail) -> case mapM s2t _tail of - Just lst -> Right $ FaceStatement lst - _ -> Left $ foldl (++) "" ["Syntax error in face value on line ", show num, " `", C.unpack line, "'" ] - - _ -> Left $ foldl (++) "" ["Unrecognized Sequence on line ", show num, " `", C.unpack line, "'" ] - - ) (zip [(1::Int)..] contents) in - - ( lefts compiled, ObjectFile (filter (not.isNop) $ rights compiled) ) - + let contents :: [L.ByteString]; contents = C.split '\n' _contents + in let mys2n str = case str of + "" -> -1 + _ -> read str + in let s2t s = case splitOn "/" s of + [a, b, c] -> Just (mapT3 mys2n (a, b, c)) + [a, b] -> Just (mapT3 mys2n (a, b, "")) + [a] -> Just (mapT3 mys2n (a, "", "")) + _ -> Nothing + in let compiled = + map + ( \(num, line) -> case words $ C.unpack line of + [] -> Right Nop -- This is an empty line + (('#' : _) : _) -> Right Nop -- This is a comment, so use a 'nop' + ("o" : _) -> Right Nop -- Not really of use + ["v", x, y, z] -> Right $ VertexStatement ((read x), (read y), (read z)) + ["vt", x, y] -> Right $ TextureStatement ((read x), (read y)) + ["vn", x, y, z] -> Right $ VertexNormalStatement ((read x), (read y), (read z)) + ["usemtl", mtl] -> Right $ UseMaterialStatement mtl + ["mtllib", lib] -> Right $ MaterialLibraryStatement lib + ("f" : _tail) -> case mapM s2t _tail of + Just lst -> Right $ FaceStatement lst + _ -> Left $ foldl (++) "" ["Syntax error in face value on line ", show num, " `", C.unpack line, "'"] + _ -> Left $ foldl (++) "" ["Unrecognized Sequence on line ", show num, " `", C.unpack line, "'"] + ) + (zip [(1 :: Int) ..] contents) + in (lefts compiled, ObjectFile (filter (not . isNop) $ rights compiled)) loadObjFromHandle :: (Read b) => Handle -> IO ([String], ObjectFile b) loadObjFromHandle = loadObjFromHandleWithFilter id loadObjFromHandleWithFilter :: (Read b) => (L.ByteString -> L.ByteString) -> Handle -> IO ([String], ObjectFile b) loadObjFromHandleWithFilter _filter handle = - liftM (loadObjFromBytestring . _filter) (L.hGetContents handle) + liftM (loadObjFromBytestring . _filter) (L.hGetContents handle) loadObjFile :: (Read b) => FilePath -> IO ([String], ObjectFile b) loadObjFile = loadObjFileWithFilter id |