98 lines
3.5 KiB
Haskell
98 lines
3.5 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Shader.Poke.Cloud (pokeCloud,pokeDust) where
|
|
|
|
import Geometry.Data
|
|
import Linear
|
|
import Dodge.Material.Color
|
|
import Color
|
|
import Control.Lens
|
|
import qualified Data.Vector.Unboxed as UV
|
|
import Dodge.Data.Cloud
|
|
import Foreign
|
|
import Graphics.GL.Core45
|
|
|
|
pokeCloud :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Cloud -> IO (Int, Int)
|
|
pokeCloud vptr iptr (nv, ni) = pokeCloudLike vptr iptr (nv,ni) . mkCloudCloudLike
|
|
|
|
pokeDust :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Dust -> IO (Int, Int)
|
|
pokeDust vptr iptr (nv, ni) = pokeCloudLike vptr iptr (nv,ni) . mkDustCloudLike
|
|
|
|
mkCloudCloudLike :: Cloud -> (Point3,Point4)
|
|
mkCloudCloudLike x = (x ^. clPos,V4 r g b a)
|
|
where
|
|
( V4 r g b a') = ( clColor $ x ^. clType)
|
|
a = a' * min 1 (fromIntegral (_clTimer x) / 100)
|
|
|
|
mkDustCloudLike :: Dust -> (Point3,Point4)
|
|
mkDustCloudLike x = (x ^. dsPos, V4 r g b a)
|
|
where
|
|
( V4 r g b a') = ( dustColor x)
|
|
a = a' * min 1 (fromIntegral (_dsTimer x) / 100)
|
|
|
|
--pokeCloud vptr iptr (nv, ni) cl = do
|
|
-- UV.imapM_ (pokeCloudVerx vptr cl nv) $ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
|
|
-- UV.imapM_ (pokeCloudIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 0, 3]
|
|
-- return (nv + 4, ni + 6)
|
|
|
|
pokeCloudLike :: Ptr Float -> Ptr GLushort -> (Int, Int) -> (Point3,Point4) -> IO (Int, Int)
|
|
pokeCloudLike vptr iptr (nv, ni) x = do
|
|
UV.imapM_ (pokeCloudLikeVerx vptr x nv)
|
|
$ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
|
|
UV.imapM_ (pokeCloudIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 0, 3]
|
|
return (nv + 4, ni + 6)
|
|
|
|
pokeCloudVerx :: Ptr Float -> Cloud -> Int -> Int -> (Float, Float) -> IO ()
|
|
{-# INLINE pokeCloudVerx #-}
|
|
pokeCloudVerx ptr cl nv i (dx, dy) =
|
|
UV.imapM_ (pokeCloudFloat ptr (nv + i)) $
|
|
UV.fromList [x, y, cz, 1, r, g, b, a, dx, dy, 0, 0]
|
|
where
|
|
V3 cx cy cz = _clPos cl
|
|
V2 x y = V2 cx cy - 20 *^ V2 dx dy
|
|
( V4 r g b a') = ( clColor $ cl ^. clType)
|
|
a = a' * min 1 (fromIntegral (_clTimer cl) / 100)
|
|
|
|
pokeCloudLikeVerx :: Ptr Float -> (Point3,Point4) -> Int -> Int -> (Float, Float) -> IO ()
|
|
{-# INLINE pokeCloudLikeVerx #-}
|
|
pokeCloudLikeVerx ptr (V3 cx cy cz,V4 r g b a) nv i (dx, dy) =
|
|
UV.imapM_ (pokeCloudFloat ptr (nv + i)) $
|
|
UV.fromList [x, y, cz, 1, r, g, b, a, dx, dy, 0, 0]
|
|
where
|
|
V2 x y = V2 cx cy - 20 *^ V2 dx dy
|
|
|
|
clColor :: CloudType -> Color
|
|
clColor = \case
|
|
Smoke -> greyN 0.7
|
|
RocketSmoke -> greyN 0.5
|
|
CryoReleaseCloud -> white
|
|
GasCloud -> green
|
|
|
|
pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
|
|
{-# INLINE pokeCloudFloat #-}
|
|
pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 12 + i)
|
|
|
|
pokeCloudIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
|
|
{-# INLINE pokeCloudIndex #-}
|
|
pokeCloudIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)
|
|
|
|
--pokeDust :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Dust -> IO (Int, Int)
|
|
--pokeDust vptr iptr (nv, ni) cl = do
|
|
-- UV.imapM_ (pokeDustVerx vptr cl nv) $ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
|
|
-- UV.imapM_ (pokeCloudIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 0, 3]
|
|
-- return (nv + 4, ni + 6)
|
|
|
|
pokeDustVerx :: Ptr Float -> Dust -> Int -> Int -> (Float, Float) -> IO ()
|
|
{-# INLINE pokeDustVerx #-}
|
|
pokeDustVerx ptr cl nv i (dx, dy) =
|
|
UV.imapM_ (pokeCloudFloat ptr (nv + i)) $
|
|
UV.fromList [x, y, cz, 1, r, g, b, a, dx, dy, 0, 0]
|
|
where
|
|
V3 cx cy cz = _dsPos cl
|
|
V2 x y = V2 cx cy - 20 *^ V2 dx dy
|
|
( V4 r g b a') = ( dustColor cl)
|
|
a = a' * min 1 (fromIntegral (_dsTimer cl) / 100)
|
|
|
|
dustColor :: Dust -> Color
|
|
dustColor = materialColor . _dsType
|