Add support for loading arbitrary textures in Logos (with the 'texture' builtin)

logos/exe/Logos.hs

+{-# LANGUAGE DeriveGeneric #-}
 module Main where
 
 import Definitive
@@ -7,6 +8,39 @@ import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.UI.GLFW as GLFW
 import qualified Data.StateVar as SV
 import System.Environment (getArgs)
+import Codec.Picture
+import qualified Data.Vector.Storable as V
+import Data.StateVar (($=))
+import Foreign.Storable
+import Foreign.Ptr
+import Control.Exception (SomeException(..),Exception)
+import GHC.Generics
+
+instance (Storable a,Storable b) => Storable (a,b) where
+  sizeOf x = sizeOf (fst x) + sizeOf (snd x)
+  alignment x = lcm (alignment (fst x)) (alignment (snd x))
+  peek p = do
+    x <- peek (castPtr p)
+    y <- peek (castPtr $ p`plusPtr`sizeOf x)
+    return (x,y)
+  poke p (x,y) = do
+    poke (castPtr p) x
+    poke (castPtr $ p`plusPtr`sizeOf x) y
+instance (Storable a,Storable b,Storable c) => Storable (a,b,c) where
+  sizeOf ~(x,y,z) = sizeOf (x,(y,z))
+  alignment ~(x,y,z) = alignment (x,(y,z))
+  peek p = peek (castPtr p) <&> \(x,(y,z)) -> (x,y,z)
+  poke p (x,y,z) = poke (castPtr p) (x,(y,z))
+instance (Storable a,Storable b,Storable c,Storable d) => Storable (a,b,c,d) where
+  sizeOf ~(x,y,z,u) = sizeOf (x,(y,z,u))
+  alignment ~(x,y,z,u) = alignment (x,(y,z,u))
+  peek p = peek (castPtr p) <&> \(x,(y,z,u)) -> (x,y,z,u)
+  poke p (x,y,z,u) = poke (castPtr p) (x,(y,z,u))
+instance (Storable a,Storable b,Storable c,Storable d,Storable e) => Storable (a,b,c,d,e) where
+  sizeOf ~(x,y,z,u,v) = sizeOf (x,(y,z,u,v))
+  alignment ~(x,y,z,u,v) = alignment (x,(y,z,u,v))
+  peek p = peek (castPtr p) <&> \(x,(y,z,u,v)) -> (x,y,z,u,v)
+  poke p (x,y,z,u,v) = poke (castPtr p) (x,(y,z,u,v))
 
 stringWords :: String -> [String]
 stringWords = map fromString . fromBlank
@@ -23,9 +57,9 @@ stringWords = map fromString . fromBlank
                           | otherwise = fromWChar (k.(c:)) t
         fromWChar k "" = [k ""]
 
-data LogosBuiltin = Wait | Quit | Format | Print | OpenWindow | Point | Color | Texture | Draw
+data LogosBuiltin = Wait | Quit | Format | Print | OpenWindow | Point | Color Bool | Texture | TextureCoord | Draw | BindTexture
                   deriving Show
-data LogosData = P (GL.Vertex3 GL.GLdouble) | C (GL.Color3 GL.GLdouble) | T (GL.TexCoord2 GL.GLdouble)
+data LogosData = P (GL.Vertex3 GL.GLfloat) | C (GL.Color4 GL.GLfloat) | T (GL.TexCoord2 GL.GLfloat) | TI GL.TextureObject
                deriving Show
 data LogosState = LogosState {
   _running :: Bool
@@ -40,8 +74,11 @@ dict = fromAList $ map (second StackBuiltin) $
    ("print"      , Builtin_Extra Print ),
    ("window"     , Builtin_Extra OpenWindow),
    ("point"      , Builtin_Extra Point),
-   ("color"      , Builtin_Extra Color),
+   ("rgb"        , Builtin_Extra (Color False)),
+   ("rgba"       , Builtin_Extra (Color True)),
    ("texture"    , Builtin_Extra Texture),
+   ("texbind"    , Builtin_Extra BindTexture),
+   ("texpoint"   , Builtin_Extra TextureCoord),
    ("draw"       , Builtin_Extra Draw),
                    
    ("def"        , Builtin_Def         ),
@@ -81,7 +118,7 @@ dict = fromAList $ map (second StackBuiltin) $
    ("delete"     , Builtin_Delete      ),
    ("keys"       , Builtin_Keys        )]
 
-fromStack (StackSymbol x) = read x :: GL.GLdouble
+fromStack (StackSymbol x) = read x :: GL.GLfloat
 fromStack (StackInt n) = fromIntegral n
 fromStack _ = undefined
 
@@ -116,9 +153,14 @@ runLogos OpenWindow = do
   case st of
     StackInt h:StackInt w:st' -> do
       runStackState $ put st'
-      liftIO $ do
-        void $ GLFW.openWindow (GL.Size (fromIntegral w) (fromIntegral h)) [GLFW.DisplayRGBBits 8 8 8, GLFW.DisplayAlphaBits 8] GLFW.Window
-        
+      void $ liftIO $ do
+        GLFW.openWindowHint GLFW.FSAASamples 4
+        GLFW.openWindowHint GLFW.OpenGLVersionMajor 3
+        GLFW.openWindowHint GLFW.OpenGLVersionMinor 3
+        GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCoreProfile
+ 
+        success <- GLFW.openWindow (GL.Size (fromIntegral w) (fromIntegral h)) [GLFW.DisplayRGBBits 8 8 8, GLFW.DisplayAlphaBits 8, GLFW.DisplayDepthBits 8] GLFW.Window
+        if not success then throw $ SomeException GLFWWindowOpenException else (initGL >> initShaders)
     _ -> unit
 runLogos Point = do
   st <- runStackState get
@@ -126,18 +168,58 @@ runLogos Point = do
     (fromStack -> z):(fromStack -> y):(fromStack -> x):st' -> do
       runStackState $ put $ StackExtra (Opaque (P (GL.Vertex3 x y z))):st'
     _ -> unit
-runLogos Color = do
+runLogos (Color isRGBA) = do
   st <- runStackState get
   case st of
-    (fromStack -> b):(fromStack -> g):(fromStack -> r):st' -> do
-      runStackState $ put $ StackExtra (Opaque (C (GL.Color3 r g b))):st'
+    (fromStack -> a):(fromStack -> b):(fromStack -> g):(fromStack -> r):st' | isRGBA -> do
+      runStackState $ put $ StackExtra (Opaque (C (GL.Color4 r g b a))):st'
+    (fromStack -> b):(fromStack -> g):(fromStack -> r):st' | not isRGBA -> do
+      runStackState $ put $ StackExtra (Opaque (C (GL.Color4 r g b 1.0))):st'
     _ -> unit
-runLogos Texture = do
+runLogos TextureCoord = do
   st <- runStackState get
   case st of
     (fromStack -> y):(fromStack -> x):st' -> do
       runStackState $ put $ StackExtra (Opaque (T (GL.TexCoord2 x y))):st'
     _ -> unit
+runLogos BindTexture = do
+  st <- runStackState get
+  case st of
+    StackExtra (Opaque (TI tex)):st' -> do
+      liftIO $ do
+        GL.textureBinding GL.Texture2D $= Just tex
+      runStackState $ put st'
+    _ -> unit
+runLogos Texture = do
+  st <- runStackState get
+  case st of
+    StackSymbol file:StackSymbol name:st' -> do
+      runStackState (put st')
+      textureLoaded <- liftIO $ do
+        imgbytes <- readChunk file
+        let img = convertRGB8 <$> decodeImage imgbytes
+        tex@(GL.TextureObject texi) <- GL.genObjectName
+        case img of
+          Right (Image w h imgd) -> do
+            GL.activeTexture $= GL.TextureUnit texi
+            GL.textureBinding GL.Texture2D $= Just tex
+            V.unsafeWith imgd $ \imgp -> do
+              GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0 (GL.PixelData GL.RGB GL.UnsignedByte imgp)
+            GL.textureFilter GL.Texture2D $= ((GL.Linear',Nothing),GL.Linear')
+            GL.generateMipmap' GL.Texture2D
+            Just prog <- SV.get GL.currentProgram
+            ul <- GL.uniformLocation prog name
+            GL.uniform (debug ul) $= GL.TextureUnit texi
+            return $ Just tex
+          Left err -> do
+            putStrLn err
+            return Nothing
+      case textureLoaded of
+        Just tex -> runStackState $ modify (StackExtra (Opaque (TI tex)):)
+        Nothing -> unit
+
+    _ -> unit
+
 runLogos Draw = do
   st <- runStackState get
   case st of
@@ -149,26 +231,90 @@ runLogos Draw = do
               "triangles" -> GL.Triangles
               "points" -> GL.Points
               _ -> GL.Points
-        GL.renderPrimitive mode $ for_ l $ \case
-          StackExtra (Opaque (P v)) -> GL.vertex v
-          StackExtra (Opaque (C c)) -> GL.color c
-          StackExtra (Opaque (T t)) -> GL.texCoord t
-          _ -> unit
+            extras = [x | StackExtra (Opaque x) <- l]
+            fullVertices = go zacc extras
+              where zacc = (GL.Color4 0 0 0 0,GL.TexCoord2 0 0)
+                    go (c,tx) (P v:t) = (c,tx,v):go zacc t
+                    go (_,tx) (C c:t) = go (c,tx) t
+                    go (c,_)  (T tx:t) = go (c,tx) t
+                    go acc      (h:t) = go acc t
+                    go _ [] = []
+            newVec f = GL.genObjectName <*= \vb -> do
+              let vs = V.unfoldr (\case
+                                     h:t -> Just (f h,t)
+                                     [] -> Nothing) fullVertices
+              GL.bindBuffer GL.ArrayBuffer $= Just vb
+              V.unsafeWith vs $ \p -> do
+                GL.bufferData GL.ArrayBuffer $= (fromIntegral (V.length vs * sizeOf (vs V.! 0)),p,GL.StaticDraw)
+        
+        Just prog <- SV.get GL.currentProgram
+        m <- GL.newMatrix GL.ColumnMajor [1,0,0,0 , 0,1,0,0 , 0,0,1,0 , 0,0,0,1]
+        vpu <- GL.uniformLocation prog "viewMat"
+        GL.uniform vpu $= (m :: GL.GLmatrix GL.GLfloat)
+        SV.get (GL.activeUniforms prog) >>= print
+
+        cb <- newVec (\(h,_,_) -> h)
+        tb <- newVec (\(_,h,_) -> h)
+        vb <- newVec (\(_,_,h) -> h)
+
+        let withAttrib n f = do
+              l <- SV.get (GL.attribLocation prog n)
+              between (GL.vertexAttribArray l $= GL.Enabled) (GL.vertexAttribArray l $= GL.Disabled) (f l)
+            setAttrib b v n = do
+              GL.bindBuffer GL.ArrayBuffer $= Just b
+              GL.vertexAttribPointer v $= (GL.ToFloat, GL.VertexArrayDescriptor n GL.Float 0 nullPtr)
+
+        GL.clear [ GL.DepthBuffer, GL.ColorBuffer ]
+
+        withAttrib "vertexPosition" $ \vpos -> withAttrib "vertexColor" $ \vcol -> withAttrib "vertexUV" $ \vtex -> do
+          setAttrib vb vpos 3
+          setAttrib cb vcol 4
+          setAttrib tb vtex 2
+          GL.drawArrays mode 0 (fromIntegral $ length fullVertices)
         GLFW.swapBuffers
     _ -> unit
 
+data GLSLCompileException = GLSLShaderCompileError String | GLSLProgramLinkError String
+  deriving (Show,Generic)
+instance Exception GLSLCompileException
+data GLFWException = GLFWWindowOpenException
+  deriving (Show,Generic)
+instance Exception GLFWException
+
+initShaders = GL.createProgram <*= \prog -> do
+  let compileShader shType shFile = GL.createShader shType <*= \vs -> do
+        body <- readChunk shFile
+        GL.shaderSourceBS vs $= body
+        GL.compileShader vs
+        success <- SV.get (GL.compileStatus vs)
+        if success then
+          GL.attachShader prog vs
+          else throw . SomeException . GLSLShaderCompileError =<< SV.get (GL.shaderInfoLog vs)
+  compileShader GL.VertexShader "vertex.shader"
+  compileShader GL.FragmentShader "fragment.shader"
+  
+  GL.linkProgram prog
+  success <- SV.get (GL.linkStatus prog)
+  if success then 
+    GL.currentProgram $= Just prog
+    else
+    throw . SomeException . GLSLProgramLinkError =<< SV.get (GL.programInfoLog prog)
+
+initGL = do
+  vao <- GL.genObjectName
+  GL.bindVertexArrayObject $= Just vao
+  
+  GL.depthFunc            $= Just GL.Lequal
+  GL.blend                $= GL.Enabled
+  GL.blendFunc            $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+  GL.texture GL.Texture2D $= GL.Enabled
+  GL.textureFunction      $= GL.Blend
+
 main = do
   putStrLn "Initializing graphical environment..."
   between (void GLFW.initialize) GLFW.terminate $ do
-    textureLoaded <- do
-      tex <- GL.genObjectName
-      GL.textureBinding GL.Texture2D SV.$= Just tex
-      succ <- GLFW.loadTexture2D "tile.tga" []
-      return $ if succ then Just tex else Nothing
-    putStrLn $ if has t'Just textureLoaded then "Texture loaded successfully." else "Failed loading texture"
     args <- getArgs
     prelude <- fold <$> for args readString
-    putStrLn "Hello from Logos !"
     text <- readHString stdin
     let go (w:ws) = do
           execSymbol runLogos (\_ -> unit) w

logos/logos.cabal

@@ -12,7 +12,7 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 executable logos
-  build-depends: base >=4.8 && <4.10, definitive-base >=2.6 && <2.7, capricon, OpenGL, GLFW, StateVar
+  build-depends: base >=4.8 && <4.10, definitive-base >=2.6 && <2.7, capricon, OpenGL, GLFW, StateVar, JuicyPixels, vector
   default-extensions: TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies, TupleSections, MultiParamTypeClasses, Rank2Types, AllowAmbiguousTypes, RoleAnnotations, ViewPatterns, LambdaCase
   hs-source-dirs:      exe
   main-is: Logos.hs