SimpleGL (empty) → 0.9.1

raw patch · 6 files changed

+343/−0 lines, 6 filesdep +GLFWdep +JuicyPixelsdep +OpenGLsetup-changed

Dependencies added: GLFW, JuicyPixels, OpenGL, SimpleH, base, vector

Files

LICENSE +30/−0
Setup.hs +2/−0
SimpleGL.cabal +24/−0
src/SimpleH/GL.hs +190/−0
src/SimpleH/GL/Base.hs +48/−0
src/SimpleH/GL/Texture.hs +49/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Marc Coiffier++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 Marc Coiffier 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ SimpleGL.cabal view

@@ -0,0 +1,24 @@++name:                SimpleGL+version:             0.9.1+synopsis:            A Simple Graphics Library from the SimpleH framework.+description: +  synopsis: A Simple Graphics Library from the SimpleH framework.         +license:             BSD3+license-file:        LICENSE+author:              Marc Coiffier+maintainer:          marc.coiffier@gmail.com+category:            Graphics+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules: SimpleH.GL SimpleH.GL.Texture+  other-modules: SimpleH.GL.Base       +  build-depends:       base ==4.6.*, SimpleH ==1.0.*, GLFW ==0.5.*, OpenGL ==2.8.*, JuicyPixels ==3.1.*, vector ==0.10.*+  hs-source-dirs:      src+  extensions:  RebindableSyntax, NoMonomorphismRestriction+  ghc-options:  -W+source-repository head+  type: git+  location: git://github.com/lih/SimpleGL.git

+ src/SimpleH/GL.hs view

@@ -0,0 +1,190 @@+{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+module SimpleH.GL (+  module SimpleH.Reactive,module SimpleH,module SimpleH.GL.Base,+  +  -- * Creating windows & Handling events+  EventHandler,Position,Title,+  spawnWindow,+  Button(..),GLFW.KeyButtonState(..),+  Size(..),++  -- * Examining and modifying the window+  GettableStateVar,SettableStateVar,+    +  -- * Drawing the scene+  Scene,+  Widget(..),Transform(..),+  Shape(..),ShapeProp(..),+  Vertex(..),VertexProp(..),+  clearScreen,drawScene,GLFW.swapBuffers,+  +  -- ** Basic types+  Coord,+  +  -- * Utilities++  -- ** Basic colors+  white,black,grey,gray,+  red,green,blue,yellow,magenta,cyan,++  -- ** Vertices+  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++-- |Create an OpenGL window and sinks all events into the given handler. +spawnWindow :: Title -> EventHandler -> IO ()+spawnWindow title sink = do+  -- This code was partially stolen from http://www.haskell.org/haskellwiki/GLFW+  sizes <- newChan+  +  GLFW.initialize+  -- open window+  GLFW.openWindow (Size 400 400) [GLFW.DisplayAlphaBits 8] GLFW.Window+  GLFW.windowTitle $= title+  +  -- enable 2D texturing+  texture Texture2D $= Enabled +  generateMipmap Texture2D $= Enabled+  +  shadeModel $= Smooth+  -- enable antialiasing+  lineSmooth $= Enabled+  blend      $= Enabled+  blendFunc  $= (SrcAlpha, OneMinusSrcAlpha)+  lineWidth  $= 1.5+  -- set the color to clear background+  clearColor $= Color4 0 0 0 0++  -- set 2D orthogonal view inside windowSizeCallback because+  -- any change to the Window size should result in different+  -- OpenGL Viewport.+  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''++  -- Now we define our own little stuff+  -- It doesn't seem very logical to poll events when swapping buffers. +  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) ((yc-y')/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+  -- GLFW doesn't handle multithreading nicely, so we have to+  -- manually interleave polling events and rendering within+  -- the main thread (and since waiting for events may block+  -- while the rendering might occur, we have to poll regularly)+  for_ (ev^.._mapping _future._event) $ \(t,x) ->+    fix $ \polling -> do+      c <- GLFW.pollEvents >> currentTime +      if t <= pure (c+milli 10) then x else waitTill (c+milli 10) >> polling++  GLFW.closeWindow+  GLFW.terminate++milli = (/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 = 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

+ src/SimpleH/GL/Base.hs view

@@ -0,0 +1,48 @@+module SimpleH.GL.Base where++import SimpleH++-- |A two-element vector+data V2 t = V2 !t !t+          deriving Show+instance Semigroup a => Semigroup (V2 a) where (+) = plusA+instance Monoid a => Monoid (V2 a) where zero = zeroA+instance Functor V2 where map f (V2 x y) = V2 (f x) (f y)+instance Unit V2 where pure = join V2+instance Applicative V2 where+  V2 fx fy <*> V2 x y = V2 (fx x) (fy y)+instance Foldable V2 where+  fold (V2 a b) = a+b+instance Traversable V2 where+  sequence (V2 a b) = V2<$>a<*>b++-- |A three-element vector+data V3 t = V3 !t !t !t+          deriving Show+instance Semigroup a => Semigroup (V3 a) where (+) = plusA+instance Monoid a => Monoid (V3 a) where zero = zeroA+instance Functor V3 where map f (V3 x y z) = V3 (f x) (f y) (f z)+instance Unit V3 where pure = (join.join) V3+instance Applicative V3 where+  V3 fx fy fz <*> V3 x y z = V3 (fx x) (fy y) (fz z)+instance Foldable V3 where+  fold (V3 a b c) = a+b+c+instance Traversable V3 where+  sequence (V3 a b c) = V3<$>a<*>b<*>c++-- |A three-element vector+data V4 t = V4 !t !t !t !t+          deriving Show+instance Semigroup a => Semigroup (V4 a) where (+) = plusA+instance Monoid a => Monoid (V4 a) where zero = zeroA+instance Functor V4 where map f (V4 x y z w) = V4 (f x) (f y) (f z) (f w)+instance Unit V4 where pure = (join.join.join) V4+instance Applicative V4 where+  V4 fx fy fz fw <*> V4 x y z w = V4 (fx x) (fy y) (fz z) (fw w)+instance Foldable V4 where+  fold (V4 a b c d) = a+b+c+d+instance Traversable V4 where+  sequence (V4 a b c d) = V4<$>a<*>b<*>c<*>d++class Graphics g where+  draw :: g -> IO ()

+ src/SimpleH/GL/Texture.hs view

@@ -0,0 +1,49 @@+{-# LANGUAGE RankNTypes #-}+module SimpleH.GL.Texture (+  Texture,+  imageTexture,readTexture,readTextures,readTextures'+  ) where++import SimpleH+import Codec.Picture+import qualified Graphics.Rendering.OpenGL as GL+import Data.Vector.Storable (Vector,unsafeWith)+import SimpleH.GL.Base+import Data.Word++data Texture = Texture GL.TextureObject (Vector Word8)+             deriving Show++data TextureFormat = RGB | RGBA | Greyscale | GreyscaleA++pixelFormats RGBA = (GL.RGBA',GL.RGBA)+pixelFormats RGB = (GL.RGB',GL.RGB)+pixelFormats Greyscale = (GL.SLuminance8,GL.Luminance)+pixelFormats GreyscaleA = (GL.SLuminance8Alpha8,GL.LuminanceAlpha)++readTexture name = at' _eitherT $ (readImage name)^._eitherT+                   >>= at _eitherT<$>imageTexture+imageTexture i = at' _eitherT $ do+  ((f,f'),w,h,d) <- at _eitherT $ pure $ case i of+    ImageRGB8 (Image w h d)  -> pure (pixelFormats RGB,w,h,d)+    ImageY8 (Image w h d)    -> pure (pixelFormats Greyscale,w,h,d)+    ImageRGBA8 (Image w h d) -> pure (pixelFormats RGBA,w,h,d)+    ImageYA8 (Image w h d)   -> pure (pixelFormats GreyscaleA,w,h,d)+    _             -> throw "Could not load image format to texture"+  +  lift $ do+    [tex] <- GL.genObjectNames 1+    GL.textureBinding GL.Texture2D GL.$= Just tex+    unsafeWith d $ GL.build2DMipmaps GL.Texture2D f (fromIntegral w) (fromIntegral h)+      . GL.PixelData f' GL.UnsignedByte+    GL.textureFilter  GL.Texture2D GL.$= ((GL.Linear', Just GL.Nearest), GL.Linear')+    GL.textureFunction GL.$= GL.Modulate+    -- GL.textureBinding GL.Texture2D GL.$= Nothing+    return (Texture tex d)++readTextures = map sequence . traverse readTexture+readTextures' = map2 (error<|>id) readTextures++instance Graphics Texture where+  draw (Texture t _) = GL.textureBinding GL.Texture2D GL.$= Just t+