diff --git a/C2HS.hs b/C2HS.hs new file mode 100644 --- /dev/null +++ b/C2HS.hs @@ -0,0 +1,220 @@ +-- C->Haskell Compiler: Marshalling library +-- +-- Copyright (c) [1999...2005] Manuel M T Chakravarty +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- 1. Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- 3. The name of the author may not be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN +-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +-- This module provides the marshaling routines for Haskell files produced by +-- C->Haskell for binding to C library interfaces. It exports all of the +-- low-level FFI (language-independent plus the C-specific parts) together +-- with the C->HS-specific higher-level marshalling routines. +-- + +module C2HS ( + + -- * Re-export the language-independent component of the FFI + module Foreign, + + -- * Re-export the C language component of the FFI + module CForeign, + + -- * Composite marshalling functions + withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, + peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, + + -- * Conditional results using 'Maybe' + nothingIf, nothingIfNull, + + -- * Bit masks + combineBitMasks, containsBitMask, extractBitMasks, + + -- * Conversion between C and Haskell types + cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum +) where + + +import Foreign + hiding (Word) + -- Should also hide the Foreign.Marshal.Pool exports in + -- compilers that export them +import CForeign + +import Monad (when, liftM) + + +-- Composite marshalling functions +-- ------------------------------- + +-- Strings with explicit length +-- +withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) +peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) + +-- Marshalling of numerals +-- + +withIntConv :: (Storable b, Integral a, Integral b) + => a -> (Ptr b -> IO c) -> IO c +withIntConv = with . cIntConv + +withFloatConv :: (Storable b, RealFloat a, RealFloat b) + => a -> (Ptr b -> IO c) -> IO c +withFloatConv = with . cFloatConv + +peekIntConv :: (Storable a, Integral a, Integral b) + => Ptr a -> IO b +peekIntConv = liftM cIntConv . peek + +peekFloatConv :: (Storable a, RealFloat a, RealFloat b) + => Ptr a -> IO b +peekFloatConv = liftM cFloatConv . peek + +-- Passing Booleans by reference +-- + +withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b +withBool = with . fromBool + +peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool +peekBool = liftM toBool . peek + + +-- Passing enums by reference +-- + +withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c +withEnum = with . cFromEnum + +peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a +peekEnum = liftM cToEnum . peek + + +-- Storing of 'Maybe' values +-- ------------------------- + +instance Storable a => Storable (Maybe a) where + sizeOf _ = sizeOf (undefined :: Ptr ()) + alignment _ = alignment (undefined :: Ptr ()) + + peek p = do + ptr <- peek (castPtr p) + if ptr == nullPtr + then return Nothing + else liftM Just $ peek ptr + + poke p v = do + ptr <- case v of + Nothing -> return nullPtr + Just v' -> new v' + poke (castPtr p) ptr + + +-- Conditional results using 'Maybe' +-- --------------------------------- + +-- Wrap the result into a 'Maybe' type. +-- +-- * the predicate determines when the result is considered to be non-existing, +-- ie, it is represented by `Nothing' +-- +-- * the second argument allows to map a result wrapped into `Just' to some +-- other domain +-- +nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b +nothingIf p f x = if p x then Nothing else Just $ f x + +-- |Instance for special casing null pointers. +-- +nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b +nothingIfNull = nothingIf (== nullPtr) + + +-- Support for bit masks +-- --------------------- + +-- Given a list of enumeration values that represent bit masks, combine these +-- masks using bitwise disjunction. +-- +combineBitMasks :: (Enum a, Bits b) => [a] -> b +combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) + +-- Tests whether the given bit mask is contained in the given bit pattern +-- (i.e., all bits set in the mask are also set in the pattern). +-- +containsBitMask :: (Bits a, Enum b) => a -> b -> Bool +bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm + in + bm' .&. bits == bm' + +-- |Given a bit pattern, yield all bit masks that it contains. +-- +-- * This does *not* attempt to compute a minimal set of bit masks that when +-- combined yield the bit pattern, instead all contained bit masks are +-- produced. +-- +extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] +extractBitMasks bits = + [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] + + +-- Conversion routines +-- ------------------- + +-- |Integral conversion +-- +cIntConv :: (Integral a, Integral b) => a -> b +cIntConv = fromIntegral + +-- |Floating conversion +-- +cFloatConv :: (RealFloat a, RealFloat b) => a -> b +cFloatConv = realToFrac +-- As this conversion by default goes via `Rational', it can be very slow... +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x + #-} + +-- |Obtain C value from Haskell 'Bool'. +-- +cFromBool :: Num a => Bool -> a +cFromBool = fromBool + +-- |Obtain Haskell 'Bool' from C value. +-- +cToBool :: Num a => a -> Bool +cToBool = toBool + +-- |Convert a C enumeration to Haskell. +-- +cToEnum :: (Integral i, Enum e) => i -> e +cToEnum = toEnum . cIntConv + +-- |Convert a Haskell enumeration to C. +-- +cFromEnum :: (Enum e, Integral i) => e -> i +cFromEnum = cIntConv . fromEnum diff --git a/Graphics/Formats/Assimp.hs b/Graphics/Formats/Assimp.hs new file mode 100644 --- /dev/null +++ b/Graphics/Formats/Assimp.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Graphics.Formats.Assimp.Storable +-- Copyright : (c) Joel Burget 2011 +-- License BSD3 +-- +-- Maintainer : Joel Burget +-- Stability : experimental +-- Portability : non-portable +-- +-- Import this module to use assimp. Please excuse the lack of documentation. +-- Everything should nearly directly mirror the original assimp, +-- documentation available here: + +module Graphics.Formats.Assimp ( + module Graphics.Formats.Assimp.Types + , module Graphics.Formats.Assimp.Storable + , module Graphics.Formats.Assimp.Fun + ) where + +import Graphics.Formats.Assimp.Types +import Graphics.Formats.Assimp.Storable +import Graphics.Formats.Assimp.Fun diff --git a/Graphics/Formats/Assimp/Fun.chs b/Graphics/Formats/Assimp/Fun.chs new file mode 100644 --- /dev/null +++ b/Graphics/Formats/Assimp/Fun.chs @@ -0,0 +1,337 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Graphics.Formats.Assimp.Fun +-- Copyright : (c) Joel Burget 2011 +-- License BSD3 +-- +-- Maintainer : Joel Burget +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines functions for interacting with assimp + +module Graphics.Formats.Assimp.Fun ( + -- * Basics + importFile + , applyPostProcessing + -- * Version information + , getVersionMinor + , getVersionMajor + , getVersionRevision + , isExtensionSupported + -- * Accessing materials + , get + , getArray + -- * Currently unused + , getErrorString + , setImportPropertyInteger + , setImportPropertyFloat + ) where + +import C2HS +import Foreign.Storable () +import Control.Monad (liftM) +import Unsafe.Coerce (unsafeCoerce) +import Data.Vect (Vec3(Vec3), Vec4(Vec4)) +import Data.List (foldl1') + +import Graphics.Formats.Assimp.Types +import Graphics.Formats.Assimp.Storable () + +#include "assimp.h" +#include "aiVersion.h" +#include "aiMaterial.h" +#include "typedefs.h" + +--withT = with -- http://blog.ezyang.com/2010/06/call-and-fun-marshalling-redux/ +with' :: (Storable a) => a -> (Ptr b -> IO c) -> IO c +with' x y = with x (y . castPtr) + +peek' :: (Storable b) => Ptr a -> IO b +peek' = peek . castPtr + +-- aiImportFileEx +-- aiImportFileFromMemory + +{#fun unsafe aiApplyPostProcessing as applyPostProcessing + {with'* `Scene', cFromEnum `PostProcessSteps'} -> `Scene' peek'*#} + +--{#fun aiGetPredefinedLogStream as ^ +-- {cFromEnum `DefaultLogStream', `String'} -> `LogStream' id#} + +-- aiAttachLogStream +-- aiEnableVerboseLogging +-- aiDetachLogStream +-- aiDetachAllLogStreams + +importFile :: String -> [PostProcessSteps] -> IO (Either String Scene) +importFile str psteps = do + let psteps' = foldl1' (.|.) $ map cFromEnum psteps + sceneptr <- withCString str $ \x -> {#call unsafe aiImportFile#} x psteps' + if sceneptr == nullPtr + then liftM Left getErrorString + else do + scene <- peek' sceneptr + {#call unsafe aiReleaseImport#} sceneptr + return $ Right scene + +{#fun unsafe aiGetErrorString as getErrorString + {} -> `String'#} + +{#fun unsafe aiIsExtensionSupported as isExtensionSupported + {`String'} -> `Bool'#} + +-- {#fun unsafe aiGetExtensionList as getExtensionList +-- {alloca- `AiString' peek'*} -> `()'#} + +-- aiGetMemoryRequirements + +{#fun unsafe aiSetImportPropertyInteger as setImportPropertyInteger + {`String', `Int'} -> `()'#} + +{#fun unsafe aiSetImportPropertyFloat as setImportPropertyFloat + {`String', `Float'} -> `()'#} + +--{# fun aiSetImportPropertyString as ^ +-- {`String', `String'} -> `()'#} + +{#fun unsafe aiGetLegalString as getLegalString + {} -> `String'#} + +{#fun unsafe aiGetVersionMinor as getVersionMinor + {} -> `CUInt' unsafeCoerce#} + +{#fun unsafe aiGetVersionMajor as getVersionMajor + {} -> `CUInt' unsafeCoerce#} + +{#fun unsafe aiGetVersionRevision as getVersionRevision + {} -> `CUInt' unsafeCoerce#} + +{#fun unsafe aiGetCompileFlags as getCompileFlags + {} -> `CompileFlags' convert#} + where convert = toEnum . cIntConv + +class ArrayGetter a where + getArray :: Material -> MatKey -> CUInt -> IO (Either String [a]) + +class SingleGetter a where + get :: Material -> MatKey -> IO (Either String a) + +instance ArrayGetter Float where + getArray = getMaterialFloatArray + +instance ArrayGetter Int where + getArray = getMaterialIntArray + +instance SingleGetter Float where + get = getMaterialFloat + +instance SingleGetter Int where + get = getMaterialInt + +instance SingleGetter Vec3 where +-- Also another case? + get mat key = (liftM . liftM) (\(Vec4 r g b a) -> Vec3 r g b) + (getMaterialColor mat key) + +instance SingleGetter Vec4 where + get = getMaterialColor + +instance SingleGetter String where + get = getMaterialString + +mCUInt = fromInteger . toInteger +mRet = toEnum . fromInteger . toInteger + +------------------------------------------------------------------------------- + +{- | + - Retrieve a material property with a specific key from the material + -} +getMaterialProperty :: Material -- ^ The material + -> MatKey -- ^ A key + -> IO (Either String MaterialProperty) +getMaterialProperty mat key = do + let (mKey, mType, mIndex) = matKeyToTuple key + (ret, prop) <- getMaterialProperty' mat mKey mType mIndex + case ret of + ReturnSuccess -> peekM prop + ReturnFailure -> return $ Left "Failed" + ReturnOutOfMemory -> return $ Left "Out of memory." + where + peekM :: Ptr MaterialProperty -> IO (Either String MaterialProperty) + peekM p = + if p == nullPtr + then return $ Left "No property found" + else liftM Right $ peek p + +{#fun unsafe aiGetMaterialProperty as getMaterialProperty' + {with'* `Material', + `String' , + mCUInt `CUInt' , + mCUInt `CUInt' , + alloca- `Ptr MaterialProperty' peek'*} -> `Return' mRet#} + +------------------------------------------------------------------------------- +{- | + - Retrieve an array of float values with a specific key from the material + - Example: + - > getMaterialFloatArray mat (KeyUvTransform Diffuse 0) 4 + -} +getMaterialFloatArray :: Material -- ^ The material + -> MatKey -- ^ A key + -> CUInt -- ^ Max number of values to retrieve + -> IO (Either String [Float]) +getMaterialFloatArray mat key max = do + let (mKey, mType, mIndex) = matKeyToTuple key + (ret, arr, max) <- getMaterialFloatArray' mat mKey mType mIndex max + case ret of + ReturnSuccess -> liftM (Right . (map unsafeCoerce)) + $ peekArray (fromIntegral max) arr + ReturnFailure -> return $ Left "Failed" + ReturnOutOfMemory -> return $ Left "Out of memory." + +{#fun unsafe aiGetMaterialFloatArray as getMaterialFloatArray' + {with'* `Material' , + `String' , + mCUInt `CUInt' , + mCUInt `CUInt' , + alloca- `Ptr CFloat' id, + with'* `CUInt' peek'*} -> `Return' mRet#} + +------------------------------------------------------------------------------- + +getMaterialFloat :: Material -> MatKey -> IO (Either String Float) +getMaterialFloat mat key = do + arr <- getMaterialFloatArray mat key 1 + return $ case arr of + Left err -> Left err + Right ans -> Right $ head ans + +------------------------------------------------------------------------------- + +getMaterialIntArray :: Material -> MatKey -> CUInt -> IO (Either String [Int]) +getMaterialIntArray mat key max = do + let (mKey, mType, mIndex) = matKeyToTuple key + (ret, arr, max) <- getMaterialIntArray' mat mKey mType mIndex max + case ret of + ReturnSuccess -> liftM (Right . (map unsafeCoerce)) + $ peekArray (fromIntegral max) arr + ReturnFailure -> return $ Left "Failed" + ReturnOutOfMemory -> return $ Left "Out of memory." + +{#fun unsafe aiGetMaterialIntegerArray as getMaterialIntArray' + {with'* `Material' , + `String' , + mCUInt `CUInt' , + mCUInt `CUInt' , + alloca- `Ptr CInt' id, + with'* `CUInt' peek'*} -> `Return' mRet#} + +------------------------------------------------------------------------------- + +getMaterialInt :: Material -> MatKey -> IO (Either String Int) +getMaterialInt mat key = do + arr <- getMaterialIntArray mat key 1 + return $ case arr of + Left err -> Left err + Right ans -> Right $ head ans + +------------------------------------------------------------------------------- + +getMaterialColor :: Material -> MatKey -> IO (Either String Vec4) +getMaterialColor mat key = do + let (mKey, mType, mIndex) = matKeyToTuple key + (ret, vec) <- getMaterialColor' mat mKey mType mIndex + return $ case ret of + ReturnSuccess -> Right vec + ReturnFailure -> Left "Failed" + ReturnOutOfMemory -> Left "Out of memory." + +-- Can't get this to work :( +-- {#fun unsafe aiGetMaterialColor as getMaterialColor' +-- {with'* `Material', +-- `String' , +-- mCUInt `CUInt' , +-- mCUInt `CUInt' , +-- alloca- `Vec4' peek'*} -> `Return' mRet#} + +getMaterialColor' :: Material -> String -> CUInt -> CUInt -> IO (Return, Vec4) +getMaterialColor' a1 a2 a3 a4 = + with a1 $ \a1' -> + withCString a2 $ \a2' -> + alloca $ \a5' -> + getMaterialColor''_ a1' a2' (mCUInt a3) (mCUInt a4) a5' >>= \res -> + peek a5' >>= \a5'' -> + return (mRet res, a5'') + +foreign import ccall unsafe "Graphics/Formats/Assimp/Fun.chs.h aiGetMaterialColor" + getMaterialColor''_ :: Ptr Material -> Ptr CChar -> CUInt -> CUInt -> Ptr Vec4 -> IO CInt + +------------------------------------------------------------------------------- + +getMaterialString :: Material -> MatKey -> IO (Either String String) +getMaterialString mat key = do + let (mKey, mType, mIndex) = matKeyToTuple key + (ret, (AiString str)) <- getMaterialString' mat mKey mType mIndex + return $ case ret of + ReturnSuccess -> Right str + ReturnFailure -> Left "Failed" + ReturnOutOfMemory -> Left "Out of memory." + +-- {#fun unsafe aiGetMaterialString as getMaterialString +-- {with'* `Material', +-- `String' , +-- mCUInt `CUInt' , +-- mCUInt `CUInt' , +-- alloca- `AiString' peek'*} -> `Return' mRet#} + +getMaterialString' :: Material -> String -> CUInt -> CUInt -> IO (Return, AiString) +getMaterialString' a1 a2 a3 a4 = + with a1 $ \a1' -> + withCString a2 $ \a2' -> + alloca $ \a5' -> + getMaterialString''_ a1' a2' (mCUInt a3) (mCUInt a4) a5' >>= \res -> + peek a5' >>= \a5'' -> + return (mRet res, a5'') + +foreign import ccall unsafe "Graphics/Formats/Assimp/Fun.chs.h aiGetMaterialString" + getMaterialString''_ :: Ptr Material -> Ptr CChar -> CUInt -> CUInt -> Ptr AiString -> IO CInt + +------------------------------------------------------------------------------- + +{#fun unsafe aiGetMaterialTextureCount as getTextureCount + {with'* `Material', + f `TextureType'} -> `CUInt' unsafeCoerce#} + where + f :: TextureType -> CInt + f = cIntConv . fromEnum + +------------------------------------------------------------------------------- + +-- getTexture :: + +-- {#fun unsafe aiGetMaterialTexture as getTexture' +-- {with'* `Material' , +-- f `TextureType', +-- mCUInt `CUInt' +-- `String' , +-- alloca- `CUInt' peek'*} -> `Return' mRet#} + +-- I'm not sure whether or not I will implement these or not. I guess I'll +-- check the source to see if they're pure. They could easily be implemented in +-- pure haskell. + +-- aiCreateQuaternionFromMatrix +-- aiDecomposeMatrix +-- aiTransposematrix4 +-- aiTransposematrix3 +-- aiTransformVecByMatrix3 +-- aiTransformVecByMatrix4 +-- aiMultiplyMatrix3 +-- aiMultiplyMatrix4 +-- aiIdentityMatrix3 +-- aiIdentityMatrix4 diff --git a/Graphics/Formats/Assimp/Storable.hsc b/Graphics/Formats/Assimp/Storable.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Formats/Assimp/Storable.hsc @@ -0,0 +1,417 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Graphics.Formats.Assimp.Storable +-- Copyright : (c) Joel Burget 2011 +-- License BSD3 +-- +-- Maintainer : Joel Burget +-- Stability : experimental +-- Portability : non-portable +-- +-- Storable instances for all data types, we leave @poke@ undefined because +-- it is not ever used + +module Graphics.Formats.Assimp.Storable where + +import C2HS +import Prelude hiding (replicate) +import Foreign.Storable +import Control.Monad (liftM, liftM2, join) +import Control.Applicative ((<$>), (<*>)) +import Data.Vect.Float (Vec2(..), Vec3(..), Vec4(..), Mat3(..), Mat4(..)) + +import Graphics.Formats.Assimp.Types + +#include "assimp.h" // Plain-C interface +#include "aiScene.h" // Output data structure +#include "aiPostProcess.h" // Post processing flags +#include "./typedefs.h" + +#include +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +-- Same as peekArray but checks for a null pointer +peekArray' :: Storable a => Int -> Ptr a -> IO [a] +peekArray' n ptr = if ptr == nullPtr + then return [] + else peekArray n ptr + +peekArrayPtr :: (Storable a) => Int -> (Ptr (Ptr a)) -> IO [a] +peekArrayPtr n p = peekArray' (fromIntegral n) p >>= mapM peek + +instance Storable Plane3d where + sizeOf _ = #size aiPlane + alignment _ = #alignment aiPlane + peek p = Plane3d <$> (#peek aiPlane, a) p + <*> (#peek aiPlane, b) p + <*> (#peek aiPlane, c) p + <*> (#peek aiPlane, d) p + poke = undefined + +instance Storable Ray where + sizeOf _ = #size aiRay + alignment _ = #alignment aiRay + peek p = do + (Vec3F pos) <- (#peek aiRay, pos) p + (Vec3F dir) <- (#peek aiRay, dir) p + return $ Ray pos dir + poke = undefined + +instance Storable Vec2F where + sizeOf _ = #size aiVector2D + alignment _ = #alignment aiVector2D + peek p = Vec2F <$> (Vec2 <$> (#peek aiVector2D, x) p + <*> (#peek aiVector2D, y) p) + poke = undefined + +instance Storable Vec3F where + sizeOf _ = #size aiVector3D + alignment _ = #alignment aiVector3D + peek p = Vec3F <$> (Vec3 <$> (#peek aiVector3D, x) p + <*> (#peek aiVector3D, y) p + <*> (#peek aiVector3D, z) p) + poke = undefined + +instance Storable Color3F where + sizeOf _ = #size aiColor3D + alignment _ = #alignment aiColor3D + peek p = Color3F <$> (Vec3 <$> (#peek aiColor3D, r) p + <*> (#peek aiColor3D, g) p + <*> (#peek aiColor3D, b) p) + poke = undefined + +instance Storable Color4F where + sizeOf _ = #size aiColor4D + alignment _ = #alignment aiColor4D + peek p = Color4F <$> (Vec4 <$> (#peek aiColor4D, r) p + <*> (#peek aiColor4D, g) p + <*> (#peek aiColor4D, b) p + <*> (#peek aiColor4D, a) p) + poke = undefined + +instance Storable MemoryInfo where + sizeOf _ = #size aiMemoryInfo + alignment _ = #alignment aiMemoryInfo + peek p = do + text <- (#peek aiMemoryInfo, textures) p + materials <- (#peek aiMemoryInfo, materials) p + meshes <- (#peek aiMemoryInfo, meshes) p + nodes <- (#peek aiMemoryInfo, nodes) p + animations <- (#peek aiMemoryInfo, animations) p + cameras <- (#peek aiMemoryInfo, cameras) p + lights <- (#peek aiMemoryInfo, lights) p + total <- (#peek aiMemoryInfo, total) p + return $ MemoryInfo text materials meshes nodes animations cameras lights + total + poke = undefined + +instance Storable Quaternion where + sizeOf _ = #size aiQuaternion + alignment _ = #alignment aiQuaternion + peek p = Quaternion <$> (#peek aiQuaternion, w) p + <*> (#peek aiQuaternion, w) p + <*> (#peek aiQuaternion, w) p + <*> (#peek aiQuaternion, w) p + poke = undefined + +instance Storable AiString where + sizeOf _ = #size aiString + alignment _ = #alignment aiString + peek p = do + start <- ((#peek aiString, data) p) :: IO (Ptr CChar) + if start == nullPtr + then return $ AiString "" + else do + len <- (#peek aiString, length) p + -- So the string is stored as an array, we need to pass a pointer to + -- peekCStringLen, so we can't just (#peek aiString, data) because that + -- would give us the value of the first word of the string instead of + -- the pointer, so we have to create a pointer. + str <- peekCStringLen (p `plusPtr` (#offset aiString, data), len) + return $ AiString str + poke = undefined + +aiStringToString :: AiString -> String +aiStringToString (AiString s) = s + +instance Storable Mat3F where + sizeOf _ = #size aiMatrix3x3 + alignment _ = #alignment aiMatrix3x3 + peek p = do + a1 <- (#peek aiMatrix3x3, a1) p + a2 <- (#peek aiMatrix3x3, a2) p + a3 <- (#peek aiMatrix3x3, a3) p + b1 <- (#peek aiMatrix3x3, b1) p + b2 <- (#peek aiMatrix3x3, b2) p + b3 <- (#peek aiMatrix3x3, b3) p + c1 <- (#peek aiMatrix3x3, c1) p + c2 <- (#peek aiMatrix3x3, c2) p + c3 <- (#peek aiMatrix3x3, c3) p + return $ Mat3F $ Mat3 + (Vec3 a1 a2 a3) + (Vec3 b1 b2 b3) + (Vec3 c1 c2 c3) + poke = undefined + +instance Storable Mat4F where + sizeOf _ = #size aiMatrix4x4 + alignment _ = #alignment aiMatrix4x4 + peek p = do + a1 <- (#peek aiMatrix4x4, a1) p + a2 <- (#peek aiMatrix4x4, a2) p + a3 <- (#peek aiMatrix4x4, a3) p + a4 <- (#peek aiMatrix4x4, a4) p + b1 <- (#peek aiMatrix4x4, b1) p + b2 <- (#peek aiMatrix4x4, b2) p + b3 <- (#peek aiMatrix4x4, b3) p + b4 <- (#peek aiMatrix4x4, b4) p + c1 <- (#peek aiMatrix4x4, c1) p + c2 <- (#peek aiMatrix4x4, c2) p + c3 <- (#peek aiMatrix4x4, c3) p + c4 <- (#peek aiMatrix4x4, c4) p + d1 <- (#peek aiMatrix4x4, d1) p + d2 <- (#peek aiMatrix4x4, d2) p + d3 <- (#peek aiMatrix4x4, d3) p + d4 <- (#peek aiMatrix4x4, d4) p + return $ Mat4F $ Mat4 + (Vec4 a1 a2 a3 a4) + (Vec4 b1 b2 b3 b4) + (Vec4 c1 c2 c3 c4) + (Vec4 d1 d2 d3 d4) + poke = undefined + +instance Storable Node where + sizeOf _ = #size aiNode + alignment _ = #alignment aiNode + peek p = do + mName <- liftM aiStringToString $ (#peek aiNode, mName) p + mTransformation <- (#peek aiNode, mTransformation) p + -- mParent <- if mParentPtr == nullPtr + -- then return Nothing + -- else (#peek aiNode, mParent) p + -- Temporary workaround so we don't end up in an infinite loop + let mParent = Nothing + mNumChildren <- (#peek aiNode, mNumChildren) p :: IO CUInt + mChildrenP'' <- (#peek aiNode ,mChildren) p >>= + peekArray' (fromIntegral mNumChildren) + mChildren <- mapM peek mChildrenP'' + mNumMeshes <- (#peek aiNode, mNumMeshes) p :: IO CUInt + mMeshes <- (#peek aiNode, mMeshes) p >>= + peekArray (fromIntegral mNumMeshes) + return $ Node mName mTransformation mParent mChildren mMeshes + poke = undefined + +instance Storable Face where + sizeOf _ = #size aiFace + alignment _ = #alignment aiFace + peek p = do + mNumIndices <- (#peek aiFace, mNumIndices) p :: IO CUInt + mIndices <- (#peek aiFace, mIndices) p + lst <- peekArray (fromIntegral mNumIndices) mIndices + return $ Face lst + poke = undefined + +instance Storable VertexWeight where + sizeOf _ = #size aiVertexWeight + alignment _ = #alignment aiVertexWeight + peek p = VertexWeight <$> (#peek aiVertexWeight, mVertexId) p + <*> (#peek aiVertexWeight, mWeight) p + poke = undefined + +instance Storable Bone where + sizeOf _ = #size aiBone + alignment _ = #alignment aiBone + peek p = do + mN <- liftM aiStringToString $ (#peek aiBone, mName) p + mNW <- (#peek aiBone, mNumWeights) p + mW <- (#peek aiBone, mWeights) p + lst <- peekArray mNW mW + mO <- (#peek aiBone, mOffsetMatrix) p + return $ Bone mN lst mO + poke = undefined + +toEnumList :: Enum a => CUInt -> [a] +toEnumList ls = + -- Find the places where the bits are set in ls, then convert them to b. + let stage1 = map (ls .&.) $ map (2^) [0..(bitSize (undefined::CUInt))] + stage2 = filter (>0) stage1 + in map (toEnum . fromIntegral) stage2 + +instance Storable Mesh where + sizeOf _ = #size aiMesh + alignment _ = #alignment aiMesh + peek p = do + -- Note for some reason I had to shift the bits right by 1 but I don't + -- think that should have been necessary. + mPrimitiveTypes <- liftM (toEnumList . (flip shiftR 1)) + ((#peek aiMesh, mPrimitiveTypes) p :: IO CUInt) + mNumVs <- liftM fromIntegral + $ ((#peek aiMesh, mNumVertices) p :: IO CUInt) + mVertices <- liftM (map (\(Vec3F x) -> x)) + $ (#peek aiMesh, mVertices) p >>= peekArray mNumVs + mNormals <- liftM (map (\(Vec3F x) -> x)) + $ (#peek aiMesh, mNormals) p >>= peekArray' mNumVs + mTangents <- liftM (map (\(Vec3F x) -> x)) + $ (#peek aiMesh, mTangents) p >>= peekArray' mNumVs + mBitangents <- liftM (map (\(Vec3F x) -> x)) + $ (#peek aiMesh, mBitangents) p >>= peekArray' mNumVs + mColors <- liftM (map (\(Color4F x) -> x)) + $ (#peek aiMesh, mColors) p >>= peekArray' mNumVs + mTextureCoords <- liftM (map (\(Vec3F x) -> x)) + $ (#peek aiMesh, mTextureCoords) p >>= peekArray' mNumVs + mNumUVComponents <- (#peek aiMesh, mNumUVComponents) p + mNumFaces <- liftM fromIntegral + ((#peek aiMesh, mNumFaces) p :: IO CUInt) + mFaces <- (#peek aiMesh, mFaces) p >>= peekArray mNumFaces + mBones <- join $ peekArrayPtr <$> ((#peek aiMesh, mNumBones) p) + <*> ((#peek aiMesh, mBones) p) + mMaterialIndex <- (#peek aiMesh, mMaterialIndex) p + mName <- liftM aiStringToString $ (#peek aiMesh, mName) p + return $ Mesh + mPrimitiveTypes mVertices mNormals mTangents mBitangents + mColors mTextureCoords mNumUVComponents mFaces mBones + mMaterialIndex mName + poke = undefined + +instance Storable MaterialProperty where + sizeOf _ = #size aiMaterialProperty + alignment _ = #alignment aiMaterialProperty + peek p = do + mKey <- liftM aiStringToString $ (#peek aiMaterialProperty, mKey) p + mSemantic <- liftM (cToEnum :: CUInt -> TextureType) $ + (#peek aiMaterialProperty, mSemantic) p + mIndex <- (#peek aiMaterialProperty, mIndex) p + -- mType <- liftM toEnum $ (#peek aiMaterialProperty, mType) p + mData <- (#peek aiMaterialProperty, mData) p >>= peekCString + -- return $ MaterialProperty mKey mSemantic mIndex mType mData + return $ MaterialProperty mKey mSemantic mIndex mData + poke = undefined + +instance Storable NodeAnim where + sizeOf _ = #size aiNodeAnim + alignment _ = #alignment aiNodeAnim + peek _ = return $ NodeAnim 0 + poke = undefined + +instance Storable MeshAnim where + sizeOf _ = #size aiMeshAnim + alignment _ = #alignment aiMeshAnim + peek _ = return $ MeshAnim 0 + poke = undefined + +instance Storable Material where + sizeOf _ = #size aiMaterial + alignment _ = #alignment aiMaterial + peek p = do + mProperties <- join $ liftM2 peekArrayPtr + (liftM fromIntegral ((#peek aiMaterial, mNumProperties) p :: IO CUInt)) + ((#peek aiMaterial, mProperties) p) + return $ Material mProperties + poke = undefined + +instance Storable Animation where + sizeOf _ = #size aiAnimation + alignment _ = #alignment aiAnimation + peek p = do + mName <- liftM aiStringToString $ (#peek aiAnimation, mName) p + mDuration <- (#peek aiAnimation, mDuration) p + mTicksPerSecond <- (#peek aiAnimation, mTicksPerSecond) p + mNumChannels <- (#peek aiAnimation, mNumChannels) p + mChannels' <- (#peek aiAnimation, mChannels) p + mChannels <- peekArray mNumChannels mChannels' + mNumMeshChannels <- (#peek aiAnimation, mNumMeshChannels) p + mMeshChannels' <- (#peek aiAnimation, mMeshChannels) p + mMeshChannels <- peekArray mNumMeshChannels mMeshChannels' + return $ Animation mName mDuration mTicksPerSecond mChannels mMeshChannels + poke = undefined + +instance Storable Light where + sizeOf _ = #size aiLight + alignment _ = #alignment aiLight + peek p = do + mName <- liftM aiStringToString $ (#peek aiLight, mName) p + mType <- liftM toEnum $ (#peek aiLight, mType) p + (Vec3F mPosition) <- (#peek aiLight, mPosition) p + (Vec3F mDirection) <- (#peek aiLight, mDirection) p + mAttenuationConstant <- (#peek aiLight, mAttenuationConstant) p + mAttenuationLinear <- (#peek aiLight, mAttenuationLinear) p + mAttenuationQuadratic <- (#peek aiLight, mAttenuationQuadratic) p + (Color3F mColorDiffuse) <- (#peek aiLight, mColorDiffuse) p + (Color3F mColorSpecular) <- (#peek aiLight, mColorSpecular) p + (Color3F mColorAmbient) <- (#peek aiLight, mColorAmbient) p + mAngleInnerCone <- (#peek aiLight, mAngleInnerCone) p + mAngleOuterCone <- (#peek aiLight, mAngleOuterCone) p + return $ Light + mName mType mPosition mDirection mAttenuationConstant + mAttenuationLinear mAttenuationQuadratic mColorDiffuse + mColorSpecular mColorAmbient mAngleInnerCone mAngleOuterCone + poke = undefined + +instance Storable Texture where + sizeOf _ = #size aiTexture + alignment _ = #alignment aiTexture + peek p = do + mWidth <- (#peek aiTexture, mWidth) p + mHeight <- (#peek aiTexture, mHeight) p + -- Should achFormatHint be included? + achFormatHint <- (#peek aiTexture, achFormatHint) p >>= peekCString + pcData' <- (#peek aiTexture, pcData) p + pcData <- if mHeight == 0 + then peekArray (fromIntegral mWidth) pcData' + else peekArray (fromIntegral (mWidth * mHeight)) pcData' + return $ Texture mWidth mHeight achFormatHint pcData + poke = undefined + +instance Storable Texel where + sizeOf _ = #size aiTexel + alignment _ = #alignment aiTexel + peek _ = return $ Texel 0 + poke = undefined + +instance Storable Camera where + sizeOf _ = #size aiCamera + alignment _ = #alignment aiCamera + peek p = do + mName <- liftM aiStringToString $ (#peek aiCamera, mName) p + (Vec3F mPosition) <- (#peek aiCamera, mPosition) p + (Vec3F mUp) <- (#peek aiCamera, mUp) p + (Vec3F mLookAt) <- (#peek aiCamera, mLookAt) p + mHorizontalFOV <- (#peek aiCamera, mHorizontalFOV) p + mClipPlaneNear <- (#peek aiCamera, mClipPlaneNear) p + mClipPlaneFar <- (#peek aiCamera, mClipPlaneFar) p + mAspect <- (#peek aiCamera, mAspect) p + return $ Camera mName mPosition mUp mLookAt mHorizontalFOV mClipPlaneNear + mClipPlaneFar mAspect + poke = undefined + +instance Storable Scene where + sizeOf _ = #size aiScene + alignment _ = #alignment aiScene + peek p = do + mFlags <- liftM toEnumList $ ((#peek aiScene, mFlags) p :: IO CUInt) + mRootNode <- (#peek aiScene, mRootNode) p >>= peek + mNumMeshes <- (#peek aiScene, mNumMeshes) p :: IO CUInt + mMeshes' <- (#peek aiScene, mMeshes) p >>= + peekArray (fromIntegral mNumMeshes) + mMeshes <- mapM peek mMeshes' + mNumMaterials <- (#peek aiScene, mNumMaterials) p :: IO CUInt + mMaterials' <- (#peek aiScene, mMaterials) p >>= + peekArray (fromIntegral mNumMaterials) + mMaterials <- mapM peek mMaterials' + mNumAnimations <- (#peek aiScene, mNumAnimations) p :: IO CUInt + mAnimations <- (#peek aiScene, mAnimations) p >>= + peekArrayPtr (fromIntegral mNumAnimations) + mNumTextures <- (#peek aiScene, mNumTextures) p :: IO CUInt + mTextures <- (#peek aiScene, mTextures) p >>= + peekArrayPtr (fromIntegral mNumTextures) + mNumLights <- (#peek aiScene, mNumLights) p :: IO CUInt + mLights <- (#peek aiScene, mLights) p >>= + peekArrayPtr (fromIntegral mNumLights) + mNumCameras <- (#peek aiScene, mNumCameras) p :: IO CUInt + mCameras <- (#peek aiScene, mCameras) p >>= + peekArrayPtr (fromIntegral mNumCameras) + return $ Scene mFlags mRootNode mMeshes mMaterials mAnimations mTextures + mLights mCameras + poke = undefined diff --git a/Graphics/Formats/Assimp/Types.chs b/Graphics/Formats/Assimp/Types.chs new file mode 100644 --- /dev/null +++ b/Graphics/Formats/Assimp/Types.chs @@ -0,0 +1,445 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Graphics.Formats.Assimp.Storable +-- Copyright : (c) Joel Burget 2011 +-- License BSD3 +-- +-- Maintainer : Joel Burget +-- Stability : experimental +-- Portability : non-portable +-- +-- Data types for (nearly) every type used in assimp. + +module Graphics.Formats.Assimp.Types ( + SceneFlags(..) + , CompileFlags(..) + , PostProcessSteps(..) + , Return(..) +-- , Origin(..) +-- , DefaultLogStream(..) + , PrimitiveType(..) + , LightSourceType(..) + , TextureOp(..) + , TextureMapMode(..) + , TextureMapping(..) + , TextureType(..) + , ShadingMode(..) -- ? + , TextureFlags(..) + , BlendMode(..) + , PropertyTypeInfo(..) + , MatKey(..) + , matKeyToTuple + , Plane3d(..) + , Ray(..) + , Vec2F(Vec2F) + , Vec3F(Vec3F) + , Vec4F(Vec4F) + , Mat3F(Mat3F) + , Mat4F(Mat4F) + , Color3F(Color3F) + , Color4F(Color4F) + , MemoryInfo(..) + , Quaternion(..) + , AiString(..) + , Node(..) + , Face(..) + , VertexWeight(..) + , Bone(..) + , Mesh(..) + , MaterialProperty(..) + , Material(..) + , NodeAnim(..) + , MeshAnim(..) + , Animation(..) + , Light(..) + , Camera(..) + , Scene(..) + , Texture(..) + , Texel(..) + , position + ) where + +import C2HS + +import Data.Vect.Float + +-- Remove the force32bit enums +#define SWIG + +#include "assimp.h" // Plain-C interface +#include "aiScene.h" // Output data structure +#include "aiPostProcess.h" // Post processing flags +#include "aiVersion.h" // Version information +#include "typedefs.h" + +{#context lib="assimp"#} +{#context prefix="ai"#} + +{#enum define SceneFlags {AI_SCENE_FLAGS_INCOMPLETE as FlagsIncomplete + , AI_SCENE_FLAGS_VALIDATED as FlagsValidated + , AI_SCENE_FLAGS_VALIDATION_WARNING as FlagsValidationWarning + , AI_SCENE_FLAGS_NON_VERBOSE_FORMAT as FlagsNonVerboseFormat + , AI_SCENE_FLAGS_TERRAIN as FlagsTerrain + }#} +instance Show SceneFlags where + show FlagsIncomplete = "FlagsIncomplete" + show FlagsValidated = "FlagsValidated" + show FlagsValidationWarning = "FlagsValidationWarning" + show FlagsNonVerboseFormat = "FlagsNonVerboseFormat" + show FlagsTerrain = "FlagsTerrain" + +{#enum define CompileFlags {ASSIMP_CFLAGS_SHARED as Shared + , ASSIMP_CFLAGS_STLPORT as StlPort + , ASSIMP_CFLAGS_DEBUG as Debug + , ASSIMP_CFLAGS_NOBOOST as NoBoost + , ASSIMP_CFLAGS_SINGLETHREADED as SingleThreaded + }#} +instance Show CompileFlags where + show Shared = "Shared" + show StlPort = "StlPort" + show Debug = "Debug" + show NoBoost = "NoBoost" + show SingleThreaded = "SingleThreaded" + +{#enum aiPostProcessSteps as PostProcessSteps {} with prefix="aiProcess_" deriving (Show, Eq)#} + +data Return = ReturnSuccess + | ReturnFailure + | ReturnOutOfMemory + deriving (Show,Eq) +instance Enum Return where + fromEnum ReturnSuccess = 0 + fromEnum ReturnFailure = (-1) + fromEnum ReturnOutOfMemory = (-3) + + toEnum 0 = ReturnSuccess + toEnum (-1) = ReturnFailure + toEnum (-3) = ReturnOutOfMemory + toEnum unmatched = error ("Return.toEnum: Cannot match " ++ show unmatched) + +--{#enum aiOrigin as Origin {} with prefix="aiOrigin_" deriving (Show, Eq)#} +--{#enum aiDefaultLogStream as DefaultLogStream {underscoreToCase} with prefix="aiDefaultLogStream" deriving (Show, Eq)#} + +data PrimitiveType = PrimitiveTypePoint + | PrimitiveTypeLine + | PrimitiveTypeTriangle + | PrimitiveTypePolygon + deriving (Show,Eq) +instance Enum PrimitiveType where + fromEnum PrimitiveTypePoint = 1 + fromEnum PrimitiveTypeLine = 2 + fromEnum PrimitiveTypeTriangle = 4 + fromEnum PrimitiveTypePolygon = 8 + + toEnum 1 = PrimitiveTypePoint + toEnum 2 = PrimitiveTypeLine + toEnum 4 = PrimitiveTypeTriangle + toEnum 8 = PrimitiveTypePolygon + toEnum unmatched = error ("PrimitiveType.toEnum: Cannot match " ++ show unmatched) + +data LightSourceType = LightSourceUndefined + | LightSourceDirectional + | LightSourcePoint + | LightSourceSpot + deriving (Show,Eq) +instance Enum LightSourceType where + fromEnum LightSourceUndefined = 0 + fromEnum LightSourceDirectional = 1 + fromEnum LightSourcePoint = 2 + fromEnum LightSourceSpot = 3 + + toEnum 0 = LightSourceUndefined + toEnum 1 = LightSourceDirectional + toEnum 2 = LightSourcePoint + toEnum 3 = LightSourceSpot + toEnum unmatched = error ("LightSourceType.toEnum: Cannot match " ++ show unmatched) + +-- Texture enums +{#enum aiTextureOp as TextureOp {} with prefix="aiTextureOp_" deriving (Show, Eq)#} +{#enum aiTextureMapMode as TextureMapMode {} with prefix="aiTextureMapMode_" deriving (Show, Eq)#} +{#enum aiTextureMapping as TextureMapping {underscoreToCase} with prefix="aiTextureMapping_" deriving (Show, Eq)#} +{#enum aiTextureType as TextureType {underscoreToCase} with prefix="aiTextureType_" deriving (Show, Eq)#} +{#enum aiShadingMode as ShadingMode {} with prefix="aiShadingMode_" deriving (Show, Eq)#} +{#enum aiTextureFlags as TextureFlags {} with prefix="aiTextureFlags_" deriving (Show, Eq)#} +{#enum aiBlendMode as BlendMode {} with prefix="aiBlendMode_" deriving (Show, Eq)#} +{#enum aiPropertyTypeInfo as PropertyTypeInfo {underscoreToCase} deriving (Show, Eq)#} + +data MatKey = KeyName + | KeyTwoSided + | KeyShadingModel + | KeyEnableWireframe + | KeyBlendFunc + | KeyOpacity + | KeyBumpScaling + | KeyShininess + | KeyReflectivity + | KeyShininessStrength + | KeyRefraction + | KeyColorDiffuse + | KeyColorAmbient + | KeyColorSpecular + | KeyColorEmissive + | KeyColorTransparent + | KeyColorReflective + | KeyGlobalBackgroundImage + | KeyTexture TextureType CUInt + | KeyUvWSrc TextureType CUInt + | KeyTexOp TextureType CUInt + | KeyMapping TextureType CUInt + | KeyTexBlend TextureType CUInt + | KeyMappingModeU TextureType CUInt + | KeyMappingModeV TextureType CUInt + | KeyTexMapAxis TextureType CUInt + | KeyUvTransform TextureType CUInt + | KeyTexFlags TextureType CUInt + +matKeyToTuple :: MatKey -> (String, CUInt, CUInt) +matKeyToTuple KeyName = ("?mat.name", 0, 0) +matKeyToTuple KeyTwoSided = ("$mat.twosided", 0, 0) +matKeyToTuple KeyShadingModel = ("$mat.shadingm", 0, 0) +matKeyToTuple KeyEnableWireframe = ("$mat.wireframe", 0, 0) +matKeyToTuple KeyBlendFunc = ("$mat.blend", 0, 0) +matKeyToTuple KeyOpacity = ("$mat.opacity", 0, 0) +matKeyToTuple KeyBumpScaling = ("$mat.bumpscaling", 0, 0) +matKeyToTuple KeyShininess = ("$mat.shininess", 0, 0) +matKeyToTuple KeyReflectivity = ("$mat.reflectivity", 0, 0) +matKeyToTuple KeyShininessStrength = ("$mat.shinpercent", 0, 0) +matKeyToTuple KeyRefraction = ("$mat.refracti", 0, 0) +matKeyToTuple KeyColorDiffuse = ("$clr.diffuse", 0, 0) +matKeyToTuple KeyColorAmbient = ("$clr.ambient", 0, 0) +matKeyToTuple KeyColorSpecular = ("$clr.specular", 0, 0) +matKeyToTuple KeyColorEmissive = ("$clr.emissive", 0, 0) +matKeyToTuple KeyColorTransparent = ("$clr.transparent", 0, 0) +matKeyToTuple KeyColorReflective = ("$clr.reflective", 0, 0) +matKeyToTuple KeyGlobalBackgroundImage = ("?bg.global", 0, 0) +matKeyToTuple (KeyTexture tType i) = ("$tex.file", fromEnum' tType, i) +matKeyToTuple (KeyUvWSrc tType i) = ("$tex.uvwsrc", fromEnum' tType, i) +matKeyToTuple (KeyTexOp tType i) = ("$tex.op", fromEnum' tType, i) +matKeyToTuple (KeyMapping tType i) = ("$tex.mapping", fromEnum' tType, i) +matKeyToTuple (KeyTexBlend tType i) = ("$tex.blend", fromEnum' tType, i) +matKeyToTuple (KeyMappingModeU tType i) = ("$tex.mapmodeu", fromEnum' tType, i) +matKeyToTuple (KeyMappingModeV tType i) = ("$tex.mapmodev", fromEnum' tType, i) +matKeyToTuple (KeyTexMapAxis tType i) = ("$tex.mapaxis", fromEnum' tType, i) +matKeyToTuple (KeyUvTransform tType i) = ("$tex.uvtrafo", fromEnum' tType, i) +matKeyToTuple (KeyTexFlags tType i) = ("$tex.flags", fromEnum' tType, i) + +fromEnum' :: TextureType -> CUInt +fromEnum' = fromInteger . toInteger . fromEnum + +data Plane3d = Plane3d + { planeA :: Float + , planeB :: Float + , planeC :: Float + , planeD :: Float + } deriving (Show) +{#pointer *aiPlane as PlanePtr -> Plane3d#} + +data Ray = Ray + { rayPos :: Vec3 + , rayDir :: Vec3 + } deriving (Show) +{#pointer *aiRay as RayPtr -> Ray#} + +newtype Vec2F = Vec2F Vec2 +newtype Vec3F = Vec3F Vec3 +newtype Vec4F = Vec4F Vec4 +newtype Mat3F = Mat3F Mat3 +newtype Mat4F = Mat4F Mat4 +newtype Color3F = Color3F Vec3 +newtype Color4F = Color4F Vec4 + +{#pointer *aiColor3D as Color3Ptr -> Color3F#} +{#pointer *aiColor4D as Color4Ptr -> Color4F#} +{#pointer *aiVector2D as Vec2Ptr -> Vec2#} +{#pointer *aiVector3D as Vec3Ptr -> Vec3#} +{#pointer *aiMatrix3x3 as Mat3Ptr -> Mat3#} +{#pointer *aiMatrix4x4 as Mat4Ptr -> Mat4#} + +data MemoryInfo = MemoryInfo + { memoryInfoTextures :: CUInt + , memoryInfoMaterials :: CUInt + , memoryInfoMeshes :: CUInt + , memoryInfoNodes :: CUInt + , memoryInfoAnimations :: CUInt + , memoryInfoCameras :: CUInt + , memoryInfoLights :: CUInt + , memoryInfoTotal :: CUInt + } deriving (Show) +{#pointer *aiMemoryInfo as MemoryInfoPtr -> MemoryInfo#} + +-- data LogStream +-- {#pointer *aiLogStream as LogStreamPtr -> LogStream#} + +data Quaternion = Quaternion + { quaternionW :: Float + , quaternionX :: Float + , quaternionY :: Float + , quaternionZ :: Float + } deriving (Show) +{#pointer *aiQuaternion as QuaternionPtr -> Quaternion#} + +newtype AiString = AiString String deriving (Show) +{#pointer *aiString as StringPtr -> AiString#} + +data Node = Node + { nodeName :: String + , transformation :: Mat4 + , parent :: Maybe Node + , children :: [Node] + , nodeMeshes :: [CUInt] -- Holds indices defining the node + } deriving (Show) +{#pointer *aiNode as NodePtr -> Node#} + +data Face = Face + { indices :: [CUInt] -- Holds indices defining the face + --, debug :: String + } deriving (Show) +{#pointer *aiFace as FacePtr -> Face#} + +data VertexWeight = VertexWeight + { vertexId :: CUInt + , weight :: CFloat + } deriving (Show) +{#pointer *aiVertexWeight as VertexWeightPtr -> VertexWeight#} + +data Bone = Bone + { boneName :: String + , weights :: [VertexWeight] + , offpokeMatrix :: Mat4 + } deriving (Show) +{#pointer *aiBone as BonePtr -> Bone#} + +data Mesh = Mesh + { primitiveTypes :: [PrimitiveType] + , vertices :: [Vec3] + , normals :: [Vec3] + , tangents :: [Vec3] + , bitangents :: [Vec3] + , colors :: [Vec4] + , textureCoords :: [Vec3] + , numUVComponents :: CUInt + , faces :: [Face] + , bones :: [Bone] + , materialIndex :: CUInt + , meshName :: String + } deriving (Show) +{#pointer *aiMesh as MeshPtr -> Mesh#} + +data MaterialProperty = MaterialProperty + { key :: String + , semantic :: TextureType + , index :: CUInt + , mData :: String + } deriving (Show) +{#pointer *aiMaterialProperty as MaterialPropertyPtr -> MaterialProperty#} + +data Material = Material + { properties :: [MaterialProperty] + } deriving (Show) +{#pointer *aiMaterial as MaterialPtr -> Material#} + +data NodeAnim = NodeAnim + { dummy'NodeAnim :: Int + } deriving (Show) + +data MeshAnim = MeshAnim + { dummy'MeshAnim :: Int + } deriving (Show) + +data Animation = Animation + { animationName :: String + , duration :: Double + , ticksPerSecond :: Double + , channels :: [NodeAnim] + , meshChannels :: [MeshAnim] + } deriving (Show) +{#pointer *aiAnimation as AnimationPtr -> Animation#} + +data Texel = Texel + { dummy'Texel :: Int + } deriving (Show) + +data Texture = Texture + { width :: CUInt + , height :: CUInt + , achFormatHint :: String + , pcData :: [Texel] + } deriving (Show) +{#pointer *aiTexture as TexturePtr -> Texture#} + +data UVTransform = UVTransform + { translation :: Vec2 + , scaling :: Vec2 + , rotation :: Float + } deriving (Show) + +data Light = Light + { lightName :: String + , mType :: LightSourceType + , lightPosition :: Vec3 + , direction :: Vec3 + , attenuationConstant :: Float + , attenuationLinear :: Float + , attenuationQuadratic :: Float + , colorDiffuse :: Vec3 + , colorSpecular :: Vec3 + , colorAmbient :: Vec3 + , angleInnerCone :: Float + , angleOuterCone :: Float + } deriving (Show) +{#pointer *aiLight as LightPtr -> Light#} + +data Camera = Camera + { cameraName :: String + , cameraPosition :: Vec3 + , up :: Vec3 + , lookAt :: Vec3 + , horizontalFOV :: Float + , clipPlaneNear :: Float + , clipPlaneFar :: Float + , aspect :: Float + } deriving (Show) +{#pointer *aiCamera as CameraPtr -> Camera#} + +class Position a where + position :: a -> Vec3 + +instance Position Camera where + position = cameraPosition + +instance Position Light where + position = lightPosition + +class Name a where + name :: a -> String + +instance Name Node where + name = nodeName + +instance Name Bone where + name = boneName + +instance Name Mesh where + name = meshName + +instance Name Animation where + name = animationName + +instance Name Light where + name = lightName + +instance Name Camera where + name = cameraName + +data Scene = Scene + { flags :: [SceneFlags] + , rootNode :: Node + , meshes :: [Mesh] + , materials :: [Material] + , animations :: [Animation] + , textures :: [Texture] + , lights :: [Light] + , cameras :: [Camera] + } deriving (Show) +{#pointer *aiScene as ScenePtr -> Scene#} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Joel Burget + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Joel Burget nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,17 @@ +import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.Utils (rawSystemExit, rawSystemStdout) +import Distribution.Verbosity +import System.Directory (setCurrentDirectory) + +main = defaultMainWithHooks simpleUserHooks + { preBuild = \a b -> makeLib a b >> preBuild simpleUserHooks a b } + +makeLib :: Args -> BuildFlags -> IO () +makeLib _ flags = do + setCurrentDirectory "./assimp" + rawSystemStdout (fromFlag $ buildVerbosity flags) "env" + ["cmake", "-DENABLE_BOOST_WORKAROUND=ON"] + rawSystemExit (fromFlag $ buildVerbosity flags) "env" + ["CFLAGS=-D_LIB", "make"] + setCurrentDirectory ".." diff --git a/assimp.cabal b/assimp.cabal new file mode 100644 --- /dev/null +++ b/assimp.cabal @@ -0,0 +1,75 @@ +Name: assimp +Version: 0.1 +Synopsis: The Assimp asset import library + +Description: + Important: Install with + @cabal install --extra-include-dirs \/usr\/local\/include\/assimp\/@ + Of course use the location of the include files on your system. + . + This library provides FFI bindings to the Assimp asset import + library. It requires Assimp to already be installed. For more + information about Assimp see the assimp website at + . + . + This release corresponds to Assimp 2.0. When this package stabilizes I + intend to track new releases of Assimp by also releasing new versions with + the same version number, but this should be considered a beta release. + Importing models is currently working. Textures and animations are + untested. + . + Here is a sample program that imports a scene and then outputs the + information contained in it. + . + > module Main where + > + > import System (getArgs) + > import Graphics.Formats.Assimp + > + > -- Defines the preprocessing we want assimp to perform + > processing = [ CalcTangentSpace + > , Triangulate + > , JoinIdenticalVertices + > , SortByPType + > ] + > + > main = do + > args <- getArgs + > scene <- importFile (head args) processing + > print scene -- Outputs all information in the scene + > getVersionMajor >>= print -- Print the major version of assimp + > getVersionMinor >>= print -- Print the minor version of assimp + > getVersionRevision >>= print -- Print the version revision of assimp + . + See + for more. + +License: BSD3 +License-file: LICENSE +Author: Joel Burget +Maintainer: joelburget@gmail.com +Copyright: Joel Burget 2011 +Category: Graphics +Build-type: Simple +Cabal-version: >= 1.6 + +Library + Exposed-modules: Graphics.Formats.Assimp + Other-modules: + Graphics.Formats.Assimp.Types + Graphics.Formats.Assimp.Storable + Graphics.Formats.Assimp.Fun + C2HS + ghc-options: -Wall + Build-depends: base >= 4 && < 5 + , haskell98 + , vect >= 0.4.6 && < 0.5 + Build-tools: c2hs, hsc2hs + Extensions: ForeignFunctionInterface + Extra-libraries: assimp + Include-dirs: + Graphics/Formats/ + +Source-repository head + type: git + location: git@github.com:joelburget/assimp.git