module SimpleH.GL (
module SimpleH.Reactive,module SimpleH,module SimpleH.GL.Base,
EventHandler,Position,Title,
spawnWindow,
Button(..),GLFW.KeyButtonState(..),
Size(..),
GettableStateVar,SettableStateVar,
Scene,
Widget(..),Transform(..),
Shape(..),ShapeProp(..),
Vertex(..),VertexProp(..),
drawScene,
Coord,
white,black,grey,gray,
red,green,blue,yellow,magenta,cyan,
vert,cvert
) where
import SimpleH
import SimpleH.Reactive
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL hiding (
Color,Position,Vertex,Polygon,Texture,
preservingMatrix,withMatrix)
import Control.Concurrent
import SimpleH.GL.Texture
import SimpleH.GL.Base
type EventHandler = Event Seconds Position -> Event Seconds (Button,GLFW.KeyButtonState) -> IO (Event Seconds (IO ()))
type Title = String
spawnWindow :: Title -> EventHandler -> IO ()
spawnWindow title sink = do
sizes <- newChan
GLFW.initialize
GLFW.openWindow (Size 400 400) [GLFW.DisplayAlphaBits 8] GLFW.Window
GLFW.windowTitle $= title
texture Texture2D $= Enabled
generateMipmap Texture2D $= Enabled
shadeModel $= Smooth
lineSmooth $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
lineWidth $= 1.5
clearColor $= Color4 0 0 0 0
GLFW.windowSizeCallback $= \ size@(Size w h) -> do
writeChan sizes size
viewport $= (GL.Position 0 0, size)
matrixMode $= Projection
loadIdentity
let w' = realToFrac w ; h' = realToFrac h
w'' = max 1 (w'/h') ; h'' = max 1 (h'/w')
ortho2D (w'') w'' (h'') h''
GLFW.disableSpecial GLFW.AutoPollEvent
let callbackE c f = do
ch <- newChan
c $= f (writeChan ch)
event (readChan ch)
_keyboard <- callbackE GLFW.keyCallback curry
_mousePos <- callbackE GLFW.mousePosCallback (promap (\(GL.Position x y) -> V2 x y))
_mouseButton <- callbackE GLFW.mouseButtonCallback curry
_size <- event (readChan sizes)
let _button = (_1%~fromK<$>_keyboard) + (_1%~MouseButton<$>_mouseButton)
fromK (GLFW.CharKey c) = CharKey c
fromK (GLFW.SpecialKey k) = SpecialKey k
relative (Size w h) (V2 x y) = V2 ((x'xc)/m) ((ycy')/m)
where x' = realToFrac x ; y' = realToFrac y
w' = realToFrac w ; h' = realToFrac h
xc = w'/2 ; yc = h'/2 ; m = min w' h'/2
ev <- sink (relative<$>Reactive (Size 1 1) _size<|*>_mousePos) _button
let period = ms 10
for_ ((ev+(const<$>Reactive unit ev<|*>_size))^.._mapping _future._event)
$ \(t,x) -> fix $ \poll -> do
c <- GLFW.pollEvents >> currentTime
if t <= pure (c+period) then when (t > pure (cperiod)) x
else waitTill (c+period) >> poll
GLFW.closeWindow
GLFW.terminate
ms = (/1000)
clearScreen = GL.clear [GL.ColorBuffer,GL.DepthBuffer]
data Button = CharKey Char
| SpecialKey GLFW.SpecialKey
| MouseButton GLFW.MouseButton
deriving (Eq,Show)
type Scene t = [Widget t]
data Widget t = Shape [ShapeProp] (Shape t)
| SubScene [Transform t] (Scene t)
data Shape t = Polygon [Vertex t]
data Vertex t = Vertex [VertexProp t] !t !t !t
data VertexProp t = Color (V4 t)
| TexCoord (V2 t)
data ShapeProp = Texture Texture
data Transform t = Translate !t !t !t
| Rotate !t (V3 t)
| Zoom !t !t !t
type Coord = GLfloat
instance Semigroup Coord
instance Monoid Coord
instance Ring Coord
type Position = V2 Coord
instance Graphics (Widget Coord) where
draw (Shape ps s) = traverse_ draw ps >> draw s
draw (SubScene trs s) = preservingMatrix $ (traverse_ draw trs >> drawScene s)
where draw (Translate dx dy dz) = translate (Vector3 dx dy dz)
draw (Rotate a (V3 ax ay az)) = rotate a (Vector3 ax ay az)
draw (Zoom zx zy zz) = scale zx zy zz
instance Graphics (Shape Coord) where
draw (Polygon p) = renderPrimitive GL.Polygon $ traverse_ draw p
instance Graphics (Vertex Coord) where
draw (Vertex ps x y z) = traverse_ draw ps >> vertex (Vertex3 x y z)
instance Graphics (VertexProp Coord) where
draw (Color (V4 r g b a)) = color (Color4 r g b a)
draw (TexCoord (V2 x y)) = texCoord (TexCoord2 x y)
instance Graphics ShapeProp where
draw (Texture t) = draw t
withMatrix f = GL.get (matrix Nothing) >>= f
preservingMatrix ma = withMatrix $ \old ->
ma <* (matrix Nothing $= (old :: GL.GLmatrix Coord))
drawScene :: Scene Coord -> IO ()
drawScene = between clearScreen GLFW.swapBuffers . traverse_ draw
instance Functor Vector3 where
map f (Vector3 x y z) = Vector3 (f x) (f y) (f z)
instance Unit Vector3 where pure = join (join Vector3)
instance Applicative Vector3 where
Vector3 fx fy fz <*> Vector3 x y z = Vector3 (fx x) (fy y) (fz z)
instance Functor Vertex3 where
map f (Vertex3 x y z) = Vertex3 (f x) (f y) (f z)
instance Unit Vertex3 where pure = join (join Vertex3)
instance Applicative Vertex3 where
Vertex3 fx fy fz <*> Vertex3 x y z = Vertex3 (fx x) (fy y) (fz z)
vert = Vertex []
cvert c = Vertex [c]
rgb r g b = V4 r g b 1
white = rgb 1 1 1
black = rgb 0 0 0
grey g = rgb g g g
gray = grey
red = rgb 1 0 0
green = rgb 0 1 0
blue = rgb 0 0 1
yellow = green+red
magenta = red+blue
cyan = green+blue