Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 355feb3c72
Fetching contributors…

Cannot retrieve contributors at this time

203 lines (167 sloc) 6.185 kb
{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators #-}
import "GLFW-b" Graphics.UI.GLFW as GLFW
import Control.Applicative hiding (Const)
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.IORef
import Data.Word
import Data.Vect
import Data.Vect.Float.Instances ()
import FRP.Elerea.Param
import qualified Data.ByteString.Char8 as SB
import qualified Data.Trie as T
import qualified Data.Vector.Storable as SV
import System.Environment
import TypeLevel.Number.Nat.Num
import Data.Typeable
import LC_API
import Graphics.Rendering.OpenGL.Raw.Core32
import LC_Mesh
import Codec.Image.STB hiding (Image)
quad :: Mesh
quad = Mesh
{ mAttributes = T.singleton "position" $ A_V2F $ SV.fromList [V2 a b, V2 a a, V2 b a, V2 b a, V2 b b, V2 a b]
, mPrimitive = P_Triangles
, mGPUData = Nothing
}
where
a = -1
b = 1
floatV :: Float -> Exp V Float
floatV = Const
floatF :: Float -> Exp F Float
floatF = Const
screenQuad :: Exp Obj (FrameBuffer N1 V4F)
screenQuad = Accumulate fragCtx PassAll frag rast clear
where
fragCtx = AccumulationContext Nothing $ ColorOp NoBlending (one' :: V4B):.ZT
clear = FrameBuffer (ColorImage n1 (V4 1 0 0 1):.ZT)
rast = Rasterize triangleCtx prims
prims = Transform vert input
input = Fetch "postSlot" Triangle (IV2F "position")
vert :: Exp V V2F -> VertexOut V2F
vert uv = VertexOut v4 (Const 1) (NoPerspective uv:.ZT)
where
v4 = pack' $ V4 u v (floatV 1) (floatV 1)
V2 u v = unpack' uv
frag :: Exp F V2F -> FragmentOut (Color V4F :+: ZZ)
frag uv' = FragmentOut $ color :. ZT
where
color = texture' smp uv
V2 u v = unpack' uv
uv = uv' @* floatF 0.5 @+ floatF 0.5
smp = Sampler LinearFilter Clamp tex
tex = TextureSlot "ScreenQuad" $ Texture2D (Float RGBA) n1
main :: IO ()
main = do
let lcnet :: Exp Obj (Image N1 V4F)
lcnet = PrjFrameBuffer "outFB" tix0 screenQuad
windowSize <- initCommon "LC DSL 2D Demo"
renderer <- compileRenderer $ ScreenOut lcnet
print $ slotUniform renderer
print $ slotStream renderer
print "renderer created"
(mousePosition,mousePositionSink) <- external (0,0)
(fblrPress,fblrPressSink) <- external (False,False,False,False,False)
compiledQuad <- compileMesh quad
obj <- addMesh renderer "postSlot" compiledQuad []
args <- getArgs
let objU = objectUniformSetter obj
slotU = uniformSetter renderer
diffuse = uniformFTexture2D "ScreenQuad" slotU
draw _ = render renderer >> swapBuffers
fname = case args of
[] -> "Panels_Diffuse.png"
n:_ -> n
Right img <- loadImage fname
diffuse =<< compileTexture2DRGBAF False True img
s <- fpsState
sc <- start $ do
u <- scene (setScreenSize renderer) slotU objU windowSize mousePosition fblrPress
return $ draw <$> u
driveNetwork sc (readInput s mousePositionSink fblrPressSink)
dispose renderer
print "renderer destroyed"
closeWindow
scene :: (Word -> Word -> IO ())
-> T.Trie InputSetter
-> T.Trie InputSetter
-> Signal (Int, Int)
-> Signal (Float, Float)
-> Signal (Bool, Bool, Bool, Bool, Bool)
-> SignalGen Float (Signal ())
scene setSize slotU objU windowSize mousePosition fblrPress = do
let setupGFX (w,h) = do
setSize (fromIntegral w) (fromIntegral h)
return ()
r <- effectful1 setupGFX windowSize
return r
vec4ToV4F :: Vec4 -> V4F
vec4ToV4F (Vec4 x y z w) = V4 x y z w
mat4ToM44F :: Mat4 -> M44F
mat4ToM44F (Mat4 a b c d) = V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d)
readInput :: State
-> ((Float, Float) -> IO a)
-> ((Bool, Bool, Bool, Bool, Bool) -> IO c)
-> IO (Maybe Float)
readInput s mousePos fblrPress = do
t <- getTime
resetTime
(x,y) <- getMousePosition
mousePos (fromIntegral x,fromIntegral y)
fblrPress =<< ((,,,,) <$> keyIsPressed KeyLeft <*> keyIsPressed KeyUp <*> keyIsPressed KeyDown <*> keyIsPressed KeyRight <*> keyIsPressed KeyRightShift)
updateFPS s t
k <- keyIsPressed KeyEsc
return $ if k then Nothing else Just (realToFrac t)
-- FRP boilerplate
driveNetwork :: (p -> IO (IO a)) -> IO (Maybe p) -> IO ()
driveNetwork network driver = do
dt <- driver
case dt of
Just dt -> do
join $ network dt
driveNetwork network driver
Nothing -> return ()
-- OpenGL/GLFW boilerplate
initCommon :: String -> IO (Signal (Int, Int))
initCommon title = do
initialize
openWindow defaultDisplayOptions
{ displayOptions_numRedBits = 8
, displayOptions_numGreenBits = 8
, displayOptions_numBlueBits = 8
, displayOptions_numAlphaBits = 8
, displayOptions_numDepthBits = 24
, displayOptions_width = 512
, displayOptions_height = 512
, displayOptions_windowIsResizable = True
, displayOptions_openGLVersion = (3,2)
, displayOptions_openGLProfile = CoreProfile
-- , displayOptions_displayMode = Fullscreen
}
setWindowTitle title
(windowSize,windowSizeSink) <- external (0,0)
setWindowSizeCallback $ \w h -> do
glViewport 0 0 (fromIntegral w) (fromIntegral h)
putStrLn $ "window size changed " ++ show (w,h)
windowSizeSink (fromIntegral w, fromIntegral h)
return windowSize
-- FPS tracking
data State = State { frames :: IORef Int, t0 :: IORef Double }
fpsState :: IO State
fpsState = State <$> newIORef 0 <*> newIORef 0
updateFPS :: State -> Double -> IO ()
updateFPS state t1 = do
let t = 1000*t1
fR = frames state
tR = t0 state
modifyIORef fR (+1)
t0' <- readIORef tR
writeIORef tR $ t0' + t
when (t + t0' >= 5000) $ do
f <- readIORef fR
let seconds = (t + t0') / 1000
fps = fromIntegral f / seconds
--putStrLn (show (round fps) ++ " FPS - " ++ show f ++ " frames in " ++ C.secs seconds)
writeIORef tR 0
writeIORef fR 0
Jump to Line
Something went wrong with that request. Please try again.