diff --git a/STL.cabal b/STL.cabal --- a/STL.cabal +++ b/STL.cabal @@ -1,16 +1,12 @@ --- Initial STL.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - name: STL -version: 0.1.0.0 +version: 0.2 synopsis: STL 3D geometry format parsing and pretty-printing description: STL is a simple file format for representing 3D objects as the triangles which form their surface. It is common in 3D printing workflows. This library provides parsing and serialization - to the ASCII STL format. The binary STL format - is not yet supported. + to and from both text and binary STL formats. homepage: http://github.com/bergey/STL license: BSD3 license-file: LICENSE @@ -22,17 +18,24 @@ -- extra-source-files: cabal-version: >=1.10 bug-reports: http://github.com/bergey/STL/issues +Tested-with: GHC == 7.6.3, GHC == 7.8.1 +Source-repository head + type: git + location: http://github.com/bergey/STL.git + library exposed-modules: Graphics.Formats.STL, Graphics.Formats.STL.Types, Graphics.Formats.STL.Parser, - Graphics.Formats.STL.Printer + Graphics.Formats.STL.Printer, + Graphics.Formats.STL.Binary -- other-modules: -- other-extensions: - build-depends: base >=4.6 && <4.7, - pretty >= 1.1 && < 1.2, + build-depends: base >=4.6 && <4.8, attoparsec >= 0.11 && < 0.12, - text >= 1.0 && < 1.2 + text >= 1.0 && < 1.2, + cereal >= 0.4 && < 0.5, + bytestring >= 0.10 && < 0.11 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Graphics/Formats/STL.hs b/src/Graphics/Formats/STL.hs --- a/src/Graphics/Formats/STL.hs +++ b/src/Graphics/Formats/STL.hs @@ -1,10 +1,11 @@ module Graphics.Formats.STL ( - prettySTL + textSTL , stlParser , STL(..), Triangle(..), Vector(..) ) where -import Graphics.Formats.STL.Printer (prettySTL) +import Graphics.Formats.STL.Binary +import Graphics.Formats.STL.Printer (textSTL) import Graphics.Formats.STL.Parser (stlParser) import Graphics.Formats.STL.Types diff --git a/src/Graphics/Formats/STL/Binary.hs b/src/Graphics/Formats/STL/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Formats/STL/Binary.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.Formats.STL.Binary () -- export only instances + where + +import Graphics.Formats.STL.Types +import Data.Word +import Control.Applicative +import Control.Monad +import Data.Serialize +import qualified Data.Text as T +import qualified Data.ByteString as BS +import Data.Text.Encoding + +instance Serialize Triangle where + get = Triangle <$> getNormal <*> t <* skip 2 where + t = (,,) <$> getVector <*> getVector <*> getVector + put (Triangle n (a, b, c)) = maybeNormal n *> v3 a *> v3 b *> v3 c *> put (0x00 :: Word16) + +instance Serialize STL where + get = do + _ <- getHeader + ct <- getWord32le + STL "" <$> replicateM (fromIntegral ct) get + put (STL n tris) = put (header n) *> putWord32le ct *> mapM_ put tris where + ct :: Word32 + ct = fromIntegral . length $ tris -- here's the space leak + +-- | header is always exactly 80 characters long +header :: T.Text -> BS.ByteString +header n = BS.concat [lib, truncatedName, padding] where + lib = encodeUtf8 "http://hackage.haskell.org/package/STL " + truncatedName = BS.take (72 - BS.length lib) . encodeUtf8 $ n + padding = BS.replicate (72 - BS.length truncatedName - BS.length lib) 0x20 +-- header _ = BS.replicate 72 0x20 -- cereal adds 8 bytes giving the length of the BS + +putFloat :: Float -> Put +putFloat = putFloat32le + +v3 :: Vector -> PutM () +v3 (x,y,z) = putFloat x *> putFloat y *> putFloat z + +maybeNormal :: Maybe Vector -> PutM () +maybeNormal n = case n of + Nothing -> v3 (0,0,0) + Just n' -> v3 n' + +getHeader :: Get () +getHeader = skip 80 + +getFloat :: Get Float +getFloat = getFloat32le + +getVector :: Get Vector +getVector = (,,) <$> getFloat <*> getFloat <*> getFloat + +getNormal :: Get (Maybe Vector) +getNormal = do + v <- getVector + return $ case v of + (0,0,0) -> Nothing + n' -> Just n' diff --git a/src/Graphics/Formats/STL/Parser.hs b/src/Graphics/Formats/STL/Parser.hs --- a/src/Graphics/Formats/STL/Parser.hs +++ b/src/Graphics/Formats/STL/Parser.hs @@ -23,17 +23,24 @@ loop = triple <$> (text "outer loop" *> ss vertex) <*> ss vertex <*> ss vertex <* text "endloop" -normalParser :: Parser Vector -normalParser = text "facet" *> text "normal" *> v3 +normalParser :: Parser (Maybe Vector) +normalParser = text "facet" *> text "normal" *> do + n <- v3 + return $ case n of + (0, 0, 0) -> Nothing + _ -> Just n vertex :: Parser Vector vertex = text "vertex" *> v3 v3 :: Parser Vector -v3 = triple <$> ss double <*> ss double <*> ss double +v3 = triple <$> ss float <*> ss float <*> ss float ss :: Parser a -> Parser a ss p = p <* skipSpace text :: Text -> Parser Text text t = string t <* skipSpace + +float :: Parser Float +float = realToFrac <$> double diff --git a/src/Graphics/Formats/STL/Printer.hs b/src/Graphics/Formats/STL/Printer.hs --- a/src/Graphics/Formats/STL/Printer.hs +++ b/src/Graphics/Formats/STL/Printer.hs @@ -1,30 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + module Graphics.Formats.STL.Printer where -import Data.Text (Text, unpack) -import Text.PrettyPrint +import qualified Data.ByteString as BS +import Data.ByteString.Lazy.Builder +import Data.ByteString.Lazy.Builder.ASCII +import Data.List (intersperse) +import Data.Monoid +import Data.Text.Encoding (encodeUtf8) -import Graphics.Formats.STL.Types +import Graphics.Formats.STL.Types --- | Convert an @STL@ value to a @Doc@, which can be converted to a --- @String@ with 'render' -prettySTL :: STL -> Doc -prettySTL s = vcat [ text "solid " <> (text . unpack $ name s) - , vcat . map triangle $ triangles s - , text "endsolid " <> (text . unpack $ name s) - ] +-- | Convert an @STL@ value to a @Builder@, which can be converted to a +-- @ByteString@ with 'toLazyByteString' +textSTL :: STL -> Builder +textSTL s = vcat [ stringUtf8 "solid " <> (byteString . encodeUtf8 $ name s) + , vcat . map triangle $ triangles s + , stringUtf8 "endsolid " <> (byteString . encodeUtf8 $ name s) + ] -triangle :: Triangle -> Doc +triangle :: Triangle -> Builder triangle (Triangle n (a, b, c)) = - vcat [ text "facet normal" <+> v3 n - , nest 4 $ vcat [ text "outer loop" - , nest 4 $ vcat [vertex a, vertex b, vertex c] - , text "endloop" - ] - , text "endfacet" - ] + vcat $ stringUtf8 "facet normal " <> maybeNormal n : + map (indent 4) [ stringUtf8 "outer loop" + , indent 4 $ vertex a + , indent 4 $ vertex b + , indent 4 $ vertex c + , stringUtf8 "endloop" + ] + ++ [stringUtf8 "endfacet"] -vertex :: Vector -> Doc -vertex v = text "vertex" <+> v3 v +maybeNormal :: Maybe Vector -> Builder +maybeNormal n = case n of + Nothing -> v3 (0,0,0) + Just n' -> v3 n' -v3 :: Vector -> Doc -v3 (x, y, z) = hsep [double x, double y, double z] +vertex :: Vector -> Builder +vertex v = stringUtf8 "vertex " <> v3 v + +v3 :: Vector -> Builder +v3 (x, y, z) = mconcat $ intersperse comma [floatDec x, floatDec y, floatDec z] + where + comma = stringUtf8 ", " + +indent :: Int -> Builder -> Builder +indent i bs = spaces <> bs where + spaces = byteString . BS.replicate i $ 0x20 -- 0x20 is UTF-8 space + +vcat :: [Builder] -> Builder +vcat bs = mconcat $ intersperse newline bs where + newline = charUtf8 '\n' diff --git a/src/Graphics/Formats/STL/Types.hs b/src/Graphics/Formats/STL/Types.hs --- a/src/Graphics/Formats/STL/Types.hs +++ b/src/Graphics/Formats/STL/Types.hs @@ -10,11 +10,11 @@ -- | A single triangle in STL is represented by a normal vector and -- three vertices. -data Triangle = Triangle { normal :: Vector +data Triangle = Triangle { normal :: Maybe Vector , vertices :: (Vector, Vector, Vector) } -type Vector = (Double, Double, Double) +type Vector = (Float, Float, Float) triple :: a -> a -> a -> (a, a, a) triple a b c = (a, b, c)