never executed always true always false
    1 {-|
    2 Module: Flaw.Visual.Geometry
    3 Description: Geometry.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE DeriveGeneric, FlexibleContexts #-}
    8 
    9 module Flaw.Visual.Geometry
   10   ( Geometry(..)
   11   , PackedGeometry(..)
   12   , packGeometry
   13   , packIndexedGeometry
   14   , loadPackedGeometry
   15   , emitGeometryAsset
   16   , loadGeometryAsset
   17   , indexGeometryVertices
   18   ) where
   19 
   20 import Control.Exception
   21 import qualified Data.ByteString as B
   22 import qualified Data.Serialize as S
   23 import qualified Data.Text as T
   24 import qualified Data.Vector.Algorithms.Intro as VAI
   25 import qualified Data.Vector.Algorithms.Search as VAS
   26 import qualified Data.Vector.Generic as VG
   27 import qualified Data.Vector.Generic.Mutable as VGM
   28 import qualified Data.Vector.Storable as VS
   29 import Data.Word
   30 import Foreign.Storable
   31 import GHC.Generics(Generic)
   32 import Language.Haskell.TH
   33 import System.IO.Unsafe
   34 
   35 import Flaw.Asset.Collada
   36 import Flaw.Book
   37 import Flaw.Build
   38 import Flaw.Exception
   39 import Flaw.Graphics
   40 import Flaw.Visual.Geometry.Vertex
   41 import Flaw.Visual.Geometry.CacheOptimization
   42 
   43 data Geometry d = Geometry
   44   { geometryVertexBuffer :: !(VertexBufferId d)
   45   , geometryIndexBuffer :: !(IndexBufferId d)
   46   , geometryIndicesCount :: {-# UNPACK #-} !Int
   47   }
   48 
   49 data PackedGeometry = PackedGeometry
   50   { packedGeometryVerticesBytes :: !B.ByteString
   51   , packedGeometryIndicesBytes :: !B.ByteString
   52   , packedGeometryIndicesCount :: {-# UNPACK #-} !Int
   53   , packedGeometryVertexStride :: {-# UNPACK #-} !Int
   54   , packedGeometryIndexTopology :: !IndexTopology
   55   , packedGeometryIndexStride :: !IndexStride
   56   } deriving Generic
   57 
   58 instance S.Serialize PackedGeometry
   59 
   60 -- | Pack raw vertices.
   61 packGeometry :: (Ord a, Storable a, VG.Vector v a, VG.Vector v Word32) => v a -> PackedGeometry
   62 packGeometry = uncurry packIndexedGeometry . indexGeometryVertices
   63 
   64 -- | Pack geometry with indices.
   65 -- Chooses indices format.
   66 packIndexedGeometry :: (Storable a, VG.Vector v a) => v a -> VS.Vector Word32 -> PackedGeometry
   67 packIndexedGeometry vertices indices = PackedGeometry
   68   { packedGeometryVerticesBytes = verticesBytes
   69   , packedGeometryIndicesBytes = indicesBytes
   70   , packedGeometryIndicesCount = VG.length indices
   71   , packedGeometryVertexStride = sizeOf (VG.head vertices)
   72   , packedGeometryIndexTopology = IndexTopologyTriangles
   73   , packedGeometryIndexStride = indexStride
   74   } where
   75   (optimizedVertices, optimizedIndices) = optimizeGeometryLocality vertices indices
   76   verticesBytes = packVector optimizedVertices
   77   (indexStride, indicesBytes) =
   78     if VG.length optimizedVertices > 0x10000 then
   79       (IndexStride32Bit, packVector optimizedIndices)
   80     else
   81       (IndexStride16Bit, packVector (VG.map fromIntegral optimizedIndices :: VS.Vector Word16))
   82 
   83 -- | Load geometry into device.
   84 loadPackedGeometry :: Device d => d -> PackedGeometry -> IO (Geometry d, IO ())
   85 loadPackedGeometry device PackedGeometry
   86   { packedGeometryVerticesBytes = verticesBytes
   87   , packedGeometryIndicesBytes = indicesBytes
   88   , packedGeometryIndicesCount = indicesCount
   89   , packedGeometryVertexStride = vertexStride
   90   , packedGeometryIndexTopology = indexTopology
   91   , packedGeometryIndexStride = indexStride
   92   } = withSpecialBook $ \bk -> do
   93   vertexBuffer <- book bk $ createStaticVertexBuffer device verticesBytes vertexStride
   94   indexBuffer <- book bk $ createStaticIndexBuffer device indicesBytes indexTopology indexStride
   95   return Geometry
   96     { geometryVertexBuffer = vertexBuffer
   97     , geometryIndexBuffer = indexBuffer
   98     , geometryIndicesCount = indicesCount
   99     }
  100 
  101 -- | Pack geometry into bytestring.
  102 emitGeometryAsset :: FilePath -> ColladaM ColladaElement -> Q B.ByteString
  103 emitGeometryAsset fileName getElement = do
  104   bytes <- loadFile fileName
  105   let
  106     eitherVertices = runCollada $ do
  107       initColladaCache bytes
  108       createColladaVertices =<< parseGeometry =<< getElement
  109   case eitherVertices of
  110     Right vertices -> return $ S.encode $ packGeometry (vertices :: VS.Vector VertexPNT)
  111     Left err -> do
  112       let msg = "failed to emit geometry asset " ++ fileName ++ ": " ++ T.unpack err
  113       reportError msg
  114       return B.empty
  115 
  116 -- | Load geometry from bytestring.
  117 loadGeometryAsset :: Device d => d -> B.ByteString -> IO (Geometry d, IO ())
  118 loadGeometryAsset device bytes = case S.decode bytes of
  119   Right packedGeometry -> loadPackedGeometry device packedGeometry
  120   Left err -> throwIO $ DescribeFirstException $ "failed to load geometry asset: " ++ err
  121 
  122 -- | Create indices for raw vertices.
  123 indexGeometryVertices :: (Ord a, VG.Vector v a, VG.Vector v Word32) => v a -> (v a, VS.Vector Word32)
  124 indexGeometryVertices vertices = unsafePerformIO $ do
  125   mVertices <- VG.thaw vertices
  126   VAI.sort mVertices
  127   uniqueVertices <- unique mVertices
  128   indices <- noDegenerateTriangles <$> VG.mapM ((fromIntegral <$>) . VAS.binarySearchL uniqueVertices) vertices
  129   resultVertices <- VG.freeze uniqueVertices
  130   return (resultVertices, indices)
  131   where
  132   unique v = if VGM.null v then return v else do
  133     let
  134       n = VGM.length v
  135       f p i =
  136         if i < n then do
  137           a <- VGM.unsafeRead v i
  138           b <- VGM.unsafeRead v p
  139           if a == b then f p (i + 1)
  140           else do
  141             let q = p + 1
  142             VGM.write v q a
  143             f q (i + 1)
  144         else return p
  145     end <- f 0 0
  146     return $ VGM.slice 0 (end + 1) v
  147   noDegenerateTriangles v = VG.create $ do
  148     let n = VG.length v
  149     indices <- VGM.new n
  150     let
  151       f p i =
  152         if i + 2 < n then do
  153           let
  154             a = v VG.! i
  155             b = v VG.! (i + 1)
  156             c = v VG.! (i + 2)
  157           if a == b || b == c || a == c then f p (i + 3)
  158           else do
  159             VGM.unsafeWrite indices p a
  160             VGM.unsafeWrite indices (p + 1) b
  161             VGM.unsafeWrite indices (p + 2) c
  162             f (p + 3) (i + 3)
  163         else return p
  164     end <- f 0 0
  165     return $ VGM.slice 0 end indices