2
\$\begingroup\$

I've been reading Haskell tutorials and books for a while, but I never actually did serious stuff with it. This is my first attempt.

It parses an OBJ-file in text format. Later on I will add some mesh-representation and more geometry stuff.

Could you please review my code and check for "haskeliness" (like, best practices and maybe if something can be done in a simpler way)? Also I have the feeling, that the ObjFileLine type is redundant. But I can't think of a way to avoid it.

An OBJ-file looks basically like this (see https://en.wikipedia.org/wiki/Wavefront_.obj_file#File_format):

# List of geometric vertices, with (x, y, z [,w]) coordinates, w is optional and defaults to 1.0.
v 0.123 0.234 0.345 1.0
v ...
# List of texture coordinates, in (u, [,v ,w]) coordinates, these will vary between 0 and 1. v, w are optional and default to 0.
vt 0.500 1 [0]
vt ...
# List of vertex normals in (x,y,z) form; normals might not be unit vectors.
vn 0.707 0.000 0.707
vn ...
# Parameter space vertices in ( u [,v] [,w] ) form; free form geometry statement ( see below )
vp 0.310000 3.210000 2.100000
vp ...
# Polygonal face element (see below)
f 1 2 3
f 3/1 4/2 5/3
f 6/4/1 3/5/3 7/6/5
f 7//1 8//2 9//3
f ...
# Line element (see below)
l 5 8 1 2 4 9

I have one file Obj/Obj.hs for the data types, which looks like this:

module Obj.Obj where

import Data.List

-- mesh vertices
data ObjVertex =
    Vertex Double Double Double
    | Vertex4 Double Double Double Double
    deriving Eq

instance Show ObjVertex where
    show (Vertex a b c) = "v " ++ show a ++ " " ++ show b ++ " " ++ show c
    show (Vertex4 a b c d) = show (Vertex a b c) ++ " " ++ show d

-- uv coordinates for textures
data ObjTexture =
    Texture1 Double
    | Texture2 Double Double
    | Texture3 Double Double Double
    deriving Eq

instance Show ObjTexture where
    show (Texture1 a) = "vt " ++ show a
    show (Texture2 a b) = show (Texture1 a) ++ " " ++ show b
    show (Texture3 a b c) = show (Texture2 a b) ++ " " ++ show c

-- face normals
data ObjNormal = 
    Normal Double Double Double
    deriving Eq

instance Show ObjNormal where
    show (Normal a b c) = "vn " ++ show a ++ " " ++ show b ++ " " ++ show c

-- parameter space
data ObjParameter = 
    Parameter1 Double
    | Parameter2 Double Double
    | Parameter3 Double Double Double
    deriving Eq

instance Show ObjParameter where
    show (Parameter1 a) = "vp " ++ show a
    show (Parameter2 a b) = show (Parameter1 a) ++ " " ++ show b
    show (Parameter3 a b c) = show (Parameter2 a b) ++ " " ++ show c

-- face connectivites
data ObjVertexIndex = 
    VertexIndex Int
    | VertexTexture Int Int
    | VertexNormal Int Int
    | VertexTextureNormal Int Int Int
    deriving Eq

instance Show ObjVertexIndex where
    show (VertexIndex a) = show a
    show (VertexTexture a b) = show a ++ "/" ++ show b
    show (VertexNormal a b) = show a ++ "//" ++ show b
    show (VertexTextureNormal a b c) = show a ++ "/" ++ show b ++ "/" ++ show c

-- faces
data ObjFace = Face [ObjVertexIndex]
deriving Eq

instance Show ObjFace where
    show (Face vertices) = "f " ++ (intercalate " " $ map show vertices)

-- polylines
data ObjPolyLine = Line [Int]
    deriving Eq

instance Show ObjPolyLine where
    show (Line vertices) = "l " ++ (intercalate " " $ map show vertices)

data ObjFile = File
    { vertices   :: [ObjVertex]
    , textures   :: [ObjTexture]
    , normals    :: [ObjNormal]
    , parameters :: [ObjParameter]
    , faces      :: [ObjFace]
    , polylines  :: [ObjPolyLine]
    }

instance Show ObjFile where
    show file = unlines $ concat [
        fmap show (vertices file),
        fmap show (textures file),
        fmap show (normals file),
        fmap show (parameters file),
        fmap show (faces file),
        fmap show (polylines file)]   

data ObjFileLine =
    V ObjVertex
    | VT ObjTexture
    | VN ObjNormal
    | VP ObjParameter
    | F ObjFace
    | L ObjPolyLine
    deriving Eq

instance Show ObjFileLine where
    show (V v) = show v
    show (VT t) = show t
    show (VN n) = show n
    show (VP p) = show p
    show (F f) = show f
    show (L l) = show l

And a Obj/Parse.hs for the parsers which looks like this:

module Obj.Parse ( parseFile ) where

import Control.Applicative ((<|>), liftA)
import Data.Char (isDigit)
import Text.ParserCombinators.ReadP

import Obj.Obj

-- Parser combinators for an OBJ file.

-- Parse numbers.
parseSign :: (Num a) => ReadP a
parseSign = do
    sign <- option '+' (char '-')
    return $ if sign == '+' then 1 else -1

parseInteger :: ReadP Int
parseInteger = do
    sign <- parseSign
    s <- many1 $ satisfy isDigit
    return $ sign * read s

parseDouble :: ReadP Double
parseDouble = (do
    sign <- parseSign
    int <- many1 $ satisfy isDigit
    char '.'
    decimal <- many1 $ satisfy isDigit
    let s = int ++ "." ++ decimal
    return $ sign * read s
    )

parseNumber = fmap fromIntegral parseInteger <|> parseDouble


-- Parse elements of an OBJ file.
vertex :: ReadP ObjVertex
vertex = do
    string "v "
    numbers <- sepBy parseNumber skipSpaces
    case numbers of
        [a, b, c]    -> return $ Vertex a b c
        [a, b, c, d] -> return $ Vertex4 a b c d
        _            -> fail ""


texture :: ReadP ObjTexture
texture = do
    string "vt "
    numbers <- sepBy parseNumber skipSpaces
    case numbers of
        [a]       -> return $ Texture1 a
        [a, b]    -> return $ Texture2 a b
        [a, b, c] -> return $ Texture3 a b c
        _         -> fail ""

normal :: ReadP ObjNormal
normal = do
    string "vn "
    numbers <- sepBy parseNumber skipSpaces
    case numbers of
        [a, b, c] -> return $ Normal a b c
        _         -> fail ""

parameter :: ReadP ObjParameter
parameter = do
    string "vp "
    numbers <- sepBy parseNumber skipSpaces
    case numbers of
        [a]       -> return $ Parameter1 a
        [a, b]    -> return $ Parameter2 a b
        [a, b, c] -> return $ Parameter3 a b c
        _         -> fail ""

vertexIndex :: ReadP ObjVertexIndex
vertexIndex = do
        a <- parseInteger
        return $ VertexIndex a
    <|> do
        a <- parseInteger
        char '/'
        b <- parseInteger
        return $ VertexTexture a b
    <|> do
        a <- parseInteger
        string "//"
        b <- parseInteger
        return $ VertexNormal a b
    <|> do
        a <- parseInteger
        char '/'
        b <- parseInteger
        char '/'
        c <- parseInteger
        return $ VertexTextureNormal a b c

face :: ReadP ObjFace
face = do
    string "f "
    vertices <- sepBy vertexIndex skipSpaces
    return $ Face vertices

objPolyline :: ReadP ObjPolyLine
objPolyline = do
    string "l "
    elements <- sepBy parseInteger skipSpaces
    return $ Line elements


-- Parse any line of an OBJ file.
parseLine :: ReadP ObjFileLine
parseLine =
    liftA V vertex
    <|> liftA VT texture
    <|> liftA VN normal
    <|> liftA VP parameter
    <|> liftA F face
    <|> liftA L objPolyline

-- An empty OBJ file.
emptyFile :: ObjFile
emptyFile = File {
    vertices = [],
    textures = [],
    normals = [],
    parameters = [],
    faces = [],
    polylines = []
}

-- Fold a list of lines to an obj file.
fileFromLines :: [ObjFileLine] -> ObjFile
fileFromLines = foldl addLine emptyFile
    where
        addLine file (V vertex) = file { vertices = vertices file ++ [vertex] }
        addLine file (VT texture) = file { textures = textures file ++ [texture] }
        addLine file (VN normal) = file { normals = normals file ++ [normal] }
        addLine file (VP parameter) = file { parameters = parameters file ++ [parameter] }
        addLine file (F face) = file { faces = faces file ++ [face] }
        addLine file (L line) = file { polylines = polylines file ++ [line] }

-- Parse an OBJ file.
parseFile :: ReadP ObjFile
parseFile = fileFromLines <$> many (do
    line <- parseLine
    char '\n'
    return line)
\$\endgroup\$
2
\$\begingroup\$

Read provides compatibility with ReadP.

parseInteger :: ReadP Int
parseInteger = readS_to_P $ readsPrec 0

parseDouble :: ReadP Double
parseDouble = readS_to_P $ readsPrec 0

Note that usually, Show instances are supposed to produce strings that can be pasted into .hs files to reproduce the value.

Why not have ObjFile = [ObjFileLine], and ObjFileLine as a single type with 15 constructors?

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.