module Resources (
createProgramResource,
createVertexBuffer,
createIndexBuffer,
useUniforms,
useProgramResource,
drawIndexVertexBuffer,
drawVertexBuffer,
VertexBuffer(..),
IndexBuffer(..),
UniformLocationSet,
UniformSet,
ContextCacheIO,
ContextCache(contextWindow,contextViewPort),
newContextCache,
setContextWindow,
liftIO,
hiddenWindowContextCache,
WinMappedTexture,
newWinMappedTexture,
bindWinMappedTexture,
Sampler(..),
Filter(..),
EdgeMode(..),
SamplerType(..),
cubeMapTargets,
getContextCache,
saveContextCache,
changeContextSize,
getCurrentOrSetHiddenContext,
ioEvaluate,
evaluateDeep,
evaluatePtr,
ShaderInfo,
ShaderKey,
ShaderKeyNode(..),
Op,
Const(..),
Uniform(..)
) where
import Graphics.Rendering.OpenGL hiding (Sampler3D, Sampler2D, Sampler1D, SamplerCube, Point, Linear, Clamp, Uniform)
import qualified Data.HashTable as HT
import qualified Graphics.UI.GLUT as GLUT
import Data.Map (Map)
import qualified Data.Map as Map
import System.Mem.StableName
import Data.Bits
import Control.Monad
import Foreign.C.Types
import Foreign.Storable
import Foreign.Marshal
import Data.List
import Data.Maybe
import Foreign.Ptr
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Control.Exception (evaluate)
import Foreign.ForeignPtr
import System.Mem.Weak (addFinalizer)
import Data.Unique
import Data.ListTrie.Patricia.Map (TrieMap)
import qualified Data.ListTrie.Patricia.Map as TrieMap
import Data.ListTrie.Base.Map (WrappedIntMap)
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
data VertexBuffer = VertexBuffer BufferObject Int
data IndexBuffer = IndexBuffer BufferObject Int DataType
type UniformLocationSet = (UniformLocation,UniformLocation,UniformLocation, Map SamplerType UniformLocation)
data SamplerType = Sampler3D | Sampler2D | Sampler1D | SamplerCube deriving (Eq, Ord, Enum, Bounded)
type UniformSet = ([Float],[Int],[Bool],Map SamplerType [(Sampler, WinMappedTexture)])
type ShaderInfo = (ShaderKey, String, UniformSet)
type ShaderKey = ([Int], [(ShaderKeyNode, [Int])])
data ShaderKeyNode = ShaderKeyUniform
| ShaderKeyConstant !Const
| ShaderKeyInput !Int
| ShaderKeyOp !Op
deriving (Eq, Ord)
type Op = String
data Const = ConstFloat Float
| ConstInt Int
| ConstBool Bool
deriving (Eq, Ord)
data Uniform = UniformFloat Float
| UniformInt Int
| UniformBool Bool
| UniformSampler SamplerType Sampler WinMappedTexture
data Sampler = Sampler Filter EdgeMode deriving (Eq, Ord)
data Filter = Point | Linear
deriving (Eq,Ord,Bounded,Enum,Show)
data EdgeMode = Wrap | Mirror | Clamp
deriving (Eq,Ord,Bounded,Enum,Show)
toGLFilter Point = ((Nearest, Just Nearest), Nearest)
toGLFilter Linear = ((Linear', Just Linear'), Linear')
toGLWrap Wrap = (Repeated, Repeat)
toGLWrap Mirror = (Mirrored, Repeat)
toGLWrap Clamp = (Repeated, ClampToEdge)
type ProgramCacheValue = (Program, (UniformLocationSet,UniformLocationSet))
type ProgramCacheMap = TrieMap Map (ShaderKeyNode, [Int]) (TrieMap Map (ShaderKeyNode, [Int]) (TrieMap WrappedIntMap Int (TrieMap WrappedIntMap Int ProgramCacheValue)))
type ProgramCache = IORef ProgramCacheMap
pCacheLookup :: ShaderKey -> ShaderKey -> ProgramCacheMap -> Maybe ProgramCacheValue
pCacheLookup (k3, k1) (k4, k2) m1 = TrieMap.lookup k1 m1 >>= TrieMap.lookup k2 >>= TrieMap.lookup k3 >>= TrieMap.lookup k4
pCacheInsert :: ShaderKey -> ShaderKey -> ProgramCacheValue -> ProgramCacheMap -> ProgramCacheMap
pCacheInsert (k3, k1) (k4, k2) v = TrieMap.alter' ins2 k1
where ins2 Nothing = Just $ TrieMap.singleton k2 $ TrieMap.singleton k3 $ TrieMap.singleton k4 v
ins2 (Just m2) = Just $ TrieMap.alter' ins3 k2 m2
ins3 Nothing = Just $ TrieMap.singleton k3 $ TrieMap.singleton k4 v
ins3 (Just m3) = Just $ TrieMap.alter' ins4 k3 m3
ins4 Nothing = Just $ TrieMap.singleton k4 v
ins4 (Just m4) = Just $ TrieMap.insert k4 v m4
type VBCache = HT.HashTable ([Int], StableName [[Float]]) VertexBuffer
type IBCache = HT.HashTable (StableName [Int]) IndexBuffer
data ContextCache = ContextCache {programCache :: ProgramCache,
vbCache :: VBCache,
ibCache :: IBCache,
contextWindow :: GLUT.Window,
contextViewPort :: Size}
newContextCache :: GLUT.Window -> IO ContextCache
newContextCache w = do
pc <- newIORef TrieMap.empty
vbc <- HT.new (==) (\(a,b) -> HT.hashString (map toEnum a) `xor` HT.hashInt (hashStableName b))
ibc <- HT.new (==) (HT.hashInt . hashStableName)
let cache = ContextCache pc vbc ibc w (Size 0 0)
saveContextCache cache
return cache
setContextWindow :: ContextCacheIO ()
setContextWindow = do w <- asks contextWindow
s <- asks contextViewPort
liftIO $ do GLUT.currentWindow $= Just w
viewport $= (Position 0 0, s)
type ContextCacheIO = ReaderT ContextCache IO
createShaderResource :: Shader s => String -> IO s
createShaderResource str = do [s] <- genObjectNames 1
shaderSource s $= [str]
compileShader s
b <- get $ compileStatus s
if b then return s
else do e <- get $ shaderInfoLog s
error $ e ++ "\nSource:\n\n" ++ str
createProgramResource :: ShaderKey -> String -> ShaderKey -> String -> Int -> ContextCacheIO (Program, (UniformLocationSet,UniformLocationSet))
createProgramResource vkey vstr fkey fstr s = do
cache <- asks programCache
m <- liftIO $ readIORef cache
case pCacheLookup vkey fkey m of
Just p -> return p
Nothing -> liftIO $ do
[p] <- genObjectNames 1
vs <- createShaderResource vstr
fs <- createShaderResource fstr
attachedShaders p $= ([vs],[fs])
mapM_
(\i -> attribLocation p ('v' : show i) $= AttribLocation i)
[0..fromIntegral ((s1) `div` 4)]
linkProgram p
b <- get $ linkStatus p
unless b $ do
e <- get $ programInfoLog p
error e
let allSamplers = [minBound..maxBound :: SamplerType]
fvu <- get $ uniformLocation p "vuf"
ivu <- get $ uniformLocation p "vui"
bvu <- get $ uniformLocation p "vub"
svus' <- mapM (\ s -> get $ uniformLocation p $ "vus" ++ show (fromEnum s)) allSamplers
let svus = Map.fromAscList $ zip allSamplers svus'
ffu <- get $ uniformLocation p "fuf"
ifu <- get $ uniformLocation p "fui"
bfu <- get $ uniformLocation p "fub"
sfus' <- mapM (\ s -> get $ uniformLocation p $ "fus" ++ show (fromEnum s)) allSamplers
let sfus = Map.fromAscList $ zip allSamplers sfus'
let p' = (p, ((fvu,ivu,bvu,svus),(ffu,ifu,bfu,sfus)))
atomicModifyIORef cache (flip (,) () . pCacheInsert vkey fkey p')
return p'
createVertexBuffer :: [[Float]] -> [Int] -> [[Float]] -> ContextCacheIO VertexBuffer
createVertexBuffer xs i v = do vName <- liftIO $ makeStableName v
let k = (i,vName)
cache <- asks vbCache
test <- liftIO $ HT.lookup cache k
case test of
Just b -> return b
Nothing -> do
w <- asks contextWindow
liftIO $ do [b] <- genObjectNames 1
bindBuffer ArrayBuffer $= Just b
let xsdata = map realToFrac $ concat xs :: [CFloat]
withArray xsdata (\p -> bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xsdata, p, StaticDraw))
let b' = VertexBuffer b $ length (head xs)
HT.insert cache k b'
addFinalizer v $ do HT.delete cache k
w' <- get GLUT.currentWindow
GLUT.currentWindow $= Just w
deleteObjectNames [b]
GLUT.currentWindow $= w'
return b'
createIndexBuffer :: [Int] -> Int -> ContextCacheIO IndexBuffer
createIndexBuffer xs vs = do cache <- asks ibCache
iName <- liftIO $ makeStableName xs
test <- liftIO $ HT.lookup cache iName
case test of
Just i -> return i
Nothing -> do
w <- asks contextWindow
liftIO $ do [b] <- genObjectNames 1
bindBuffer ElementArrayBuffer $= Just b
i <- if vs > fromIntegral (maxBound :: CUShort)
then do
withArray (map fromIntegral xs :: [CUInt]) (\p -> bufferData ElementArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xs, p, StaticDraw))
return $ IndexBuffer b (length xs) UnsignedInt
else if vs > fromIntegral (maxBound :: CUChar)
then do
withArray (map fromIntegral xs :: [CUShort]) (\p -> bufferData ElementArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xs, p, StaticDraw))
return $ IndexBuffer b (length xs) UnsignedShort
else do
withArray (map fromIntegral xs :: [CUChar]) (\p -> bufferData ElementArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xs, p, StaticDraw))
return $ IndexBuffer b (length xs) UnsignedByte
HT.insert cache iName i
addFinalizer xs $ do HT.delete cache iName
w' <- get GLUT.currentWindow
GLUT.currentWindow $= Just w
deleteObjectNames [b]
GLUT.currentWindow $= w'
return i
useProgramResource :: Program -> ContextCacheIO ()
useProgramResource p = liftIO $ currentProgram $= Just p
useUniforms :: UniformLocationSet -> UniformSet -> ContextCacheIO ()
useUniforms (fu,iu,bu,su) (f,i,b,s) = do
w <- asks contextWindow
liftIO $ do
unless (null f) $ withArray (map (TexCoord1 . realToFrac) f :: [TexCoord1 GLfloat]) $ uniformv fu (fromIntegral $ length f)
unless (null i) $ withArray (map (TexCoord1 . fromIntegral) i :: [TexCoord1 GLint]) $ uniformv iu (fromIntegral $ length i)
unless (null b) $ withArray (map (TexCoord1 . fromBool) b :: [TexCoord1 GLint]) $ uniformv bu (fromIntegral $ length b)
mapM_ (useSampler w) $ Map.toList s
where
useSampler w (t, xs) = do
let texs = nub xs
samplers <- mapM (createSampler w t) $ zip texs [0..]
let texToSamp = zip texs samplers
ss = map (fromJust . flip lookup texToSamp) xs
withArray ss $ uniformv (su Map.! t) (fromIntegral $ length ss)
createSampler w t ((Sampler f e,tex),i) = do
activeTexture $= TextureUnit i
bindWinMappedTexture (target t) w tex t
textureFilter (target t) $= toGLFilter f
mapM_ (\c -> textureWrapMode (target t) c $= toGLWrap e) [S, T, R]
return $ TexCoord1 (fromIntegral i::GLint)
target Sampler3D = Texture3D
target Sampler2D = Texture2D
target Sampler1D = Texture1D
target SamplerCube = TextureCubeMap
useVertexBuffer :: VertexBuffer -> IO ()
useVertexBuffer (VertexBuffer b s) = do bindBuffer ArrayBuffer $= Just b
mapM_
(\i -> do
let ptroffset = nullPtr `plusPtr` (sizeOf (0 :: CFloat) * i * 4)
stride = fromIntegral $ sizeOf (0 :: CFloat) * s
a = AttribLocation $ fromIntegral i
e = fromIntegral $ min (s i*4) 4
vertexAttribArray a $= Enabled
vertexAttribPointer a $= (ToFloat, VertexArrayDescriptor e Float stride ptroffset)
)
[0..(s1) `div` 4]
drawIndexVertexBuffer :: PrimitiveMode -> VertexBuffer -> IndexBuffer -> IO ()
drawIndexVertexBuffer p vb (IndexBuffer i s t) = do useVertexBuffer vb
bindBuffer ElementArrayBuffer $= Just i
drawElements p (fromIntegral s) t nullPtr
drawVertexBuffer :: PrimitiveMode -> VertexBuffer -> Int -> IO ()
drawVertexBuffer p vb s = do useVertexBuffer vb
drawArrays p 0 (fromIntegral s)
hiddenWindowContextCache :: ContextCache
hiddenWindowContextCache = unsafePerformIO $ do
GLUT.initialDisplayMode $= [ GLUT.SingleBuffered, GLUT.RGBMode, GLUT.WithAlphaComponent, GLUT.WithDepthBuffer, GLUT.WithStencilBuffer ]
w <- GLUT.createWindow "Hidden Window"
GLUT.windowStatus $= GLUT.Hidden
newContextCache w
windowContextCaches :: IORef (Map GLUT.Window ContextCache)
windowContextCaches = unsafePerformIO $ newIORef Map.empty
getContextCache :: GLUT.Window -> IO (Maybe ContextCache)
getContextCache w = do m <- atomicModifyIORef windowContextCaches (\m -> (m,m))
return $ Map.lookup w m
saveContextCache :: ContextCache -> IO ()
saveContextCache c = atomicModifyIORef windowContextCaches $ \ m -> (Map.insert (contextWindow c) c m, ())
changeContextSize :: GLUT.Window -> Size -> IO ()
changeContextSize w s = atomicModifyIORef windowContextCaches $ \ m -> (Map.adjust (\c -> c {contextViewPort = s}) w m, ())
getCurrentOrSetHiddenContext = do
mw <- get GLUT.currentWindow
case mw of Just w -> do mc <- getContextCache w
case mc of Just cache -> return cache
Nothing -> setAndGetHiddenWindow
Nothing -> setAndGetHiddenWindow
where
setAndGetHiddenWindow = do GLUT.currentWindow $= Just (contextWindow hiddenWindowContextCache)
return hiddenWindowContextCache
evaluateDeep a = do evaluate (a==a)
return a
ioEvaluate :: Eq a => a -> ContextCacheIO a
ioEvaluate = liftIO . evaluateDeep
evaluatePtr p = do a <- peek (castPtr p :: Ptr CUChar)
evaluate (a==a)
return p
type WinMappedTexture = IORef (Map GLUT.Window TextureObject)
newWinMappedTexture :: (TextureObject -> ContextCache -> IO a) -> IO WinMappedTexture
newWinMappedTexture ionew = do
cache <- getCurrentOrSetHiddenContext
[tex] <- genObjectNames 1
swapBytes Unpack $= False
lsbFirst Unpack $= False
rowLength Unpack $= 0
skipRows Unpack $= 0
skipPixels Unpack $= 0
rowAlignment Unpack $= 1
imageHeight Unpack $= 0
skipImages Unpack $= 0
ionew tex cache
ref <- newIORef $ Map.singleton (contextWindow cache) tex
mkWeakIORef ref $ do m <- readIORef ref
w <- get GLUT.currentWindow
mapM_ deleteTexture $ Map.toList m
GLUT.currentWindow $= w
return ref
where
deleteTexture (w,t) = do GLUT.currentWindow $= Just w
deleteObjectNames [t]
bindWinMappedTexture target w ref s = do
mtex <- atomicModifyIORef ref (\a -> (a, takeOne a))
case mtex of
Right tex -> textureBinding target $= Just tex
Left (w',t) -> do GLUT.currentWindow $= Just w'
textureBinding target $= Just t
ft <- get $ textureLevelRange target
f <- get $ textureInternalFormat (Left target) 0
swapBytes Unpack $= False
lsbFirst Unpack $= False
rowLength Unpack $= 0
skipRows Unpack $= 0
skipPixels Unpack $= 0
rowAlignment Unpack $= 1
imageHeight Unpack $= 0
skipImages Unpack $= 0
swapBytes Pack $= False
lsbFirst Pack $= False
rowLength Pack $= 0
skipRows Pack $= 0
skipPixels Pack $= 0
rowAlignment Pack $= 1
imageHeight Pack $= 0
skipImages Pack $= 0
tex <- transferTexture s ft f
textureLevelRange target $= ft
atomicModifyIORef ref (flip (,) () . Map.insertWith (const id) w tex)
where takeOne a = case Map.lookup w a of
Nothing -> Left $ Map.elemAt 0 a
Just t -> Right t
createTexInWin = do GLUT.currentWindow $= Just w
[tex] <- genObjectNames 1
textureBinding target $= Just tex
return tex
transferTexture Sampler3D (from,to) f = do
psSize <- mapM getDataAndSize3D [from..to]
tex <- createTexInWin
mapM_ (setDataWithSize3D f) $ zip psSize [from..to]
return tex
transferTexture Sampler2D (from,to) f = do
psSize <- mapM getDataAndSize2D [from..to]
tex <- createTexInWin
mapM_ (setDataWithSize2D f) $ zip psSize [from..to]
return tex
transferTexture Sampler1D (from,to) f = do
psSize <- mapM getDataAndSize1D [from..to]
tex <- createTexInWin
mapM_ (setDataWithSize1D f) $ zip psSize [from..to]
return tex
transferTexture SamplerCube (from,to) f = do
psSize <- mapM getDataAndSizeCube [(n,side) | n <- [from..to], side <- cubeMapTargets]
tex <- createTexInWin
mapM_ (setDataWithSizeCube f) $ zip psSize [(n,side) | n <- [from..to], side <- cubeMapTargets]
return tex
getDataAndSize3D n = do
s@(TextureSize3D x y z) <- get $ textureSize3D (Left Texture3D) n
fp <- mallocForeignPtrBytes (fromIntegral x * fromIntegral y * fromIntegral z * 4 * sizeOf (undefined :: Float))
withForeignPtr fp $ \ p -> getTexImage (Left Texture3D) n (PixelData RGBA Float p)
return (s,fp)
setDataWithSize3D f ((s,fp),n) =
withForeignPtr fp $ \ p -> texImage3D NoProxy n f s 0 (PixelData RGBA Float p)
getDataAndSize2D n = do
s@(TextureSize2D x y) <- get $ textureSize2D (Left Texture2D) n
fp <- mallocForeignPtrBytes (fromIntegral x * fromIntegral y * 4 * sizeOf (undefined :: Float))
withForeignPtr fp $ \ p -> getTexImage (Left Texture2D) n (PixelData RGBA Float p)
return (s,fp)
setDataWithSize2D f ((s,fp),n) =
withForeignPtr fp $ \ p -> texImage2D Nothing NoProxy n f s 0 (PixelData RGBA Float p)
getDataAndSize1D n = do
s@(TextureSize1D x) <- get $ textureSize1D (Left Texture1D) n
fp <- mallocForeignPtrBytes (fromIntegral x * 4 * sizeOf (undefined :: Float))
withForeignPtr fp $ \ p -> getTexImage (Left Texture2D) n (PixelData RGBA Float p)
return (s,fp)
setDataWithSize1D f ((s,fp),n) =
withForeignPtr fp $ \ p -> texImage1D NoProxy n f s 0 (PixelData RGBA Float p)
getDataAndSizeCube (n,side) = do
s@(TextureSize2D x y) <- get $ textureSize2D (Right side) n
fp <- mallocForeignPtrBytes (fromIntegral x * fromIntegral y * 4 * sizeOf (undefined :: Float))
withForeignPtr fp $ \ p -> getTexImage (Right side) n (PixelData RGBA Float p)
return (s,fp)
setDataWithSizeCube f ((s,fp),(n,side)) =
withForeignPtr fp $ \ p -> texImage2D (Just side) NoProxy n f s 0 (PixelData RGBA Float p)
cubeMapTargets = [TextureCubeMapPositiveX, TextureCubeMapNegativeX, TextureCubeMapPositiveY, TextureCubeMapNegativeY, TextureCubeMapPositiveZ, TextureCubeMapNegativeZ]