Commit 29b12aa6 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

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

parent 5c1dfaea
{-# LANGUAGE DeriveGeneric #-}
module Main where module Main where
import Definitive import Definitive
...@@ -7,6 +8,39 @@ import qualified Graphics.Rendering.OpenGL as GL ...@@ -7,6 +8,39 @@ import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.UI.GLFW as GLFW
import qualified Data.StateVar as SV import qualified Data.StateVar as SV
import System.Environment (getArgs) 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 :: String -> [String]
stringWords = map fromString . fromBlank stringWords = map fromString . fromBlank
...@@ -23,9 +57,9 @@ stringWords = map fromString . fromBlank ...@@ -23,9 +57,9 @@ stringWords = map fromString . fromBlank
| otherwise = fromWChar (k.(c:)) t | otherwise = fromWChar (k.(c:)) t
fromWChar k "" = [k ""] 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 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 deriving Show
data LogosState = LogosState { data LogosState = LogosState {
_running :: Bool _running :: Bool
...@@ -40,8 +74,11 @@ dict = fromAList $ map (second StackBuiltin) $ ...@@ -40,8 +74,11 @@ dict = fromAList $ map (second StackBuiltin) $
("print" , Builtin_Extra Print ), ("print" , Builtin_Extra Print ),
("window" , Builtin_Extra OpenWindow), ("window" , Builtin_Extra OpenWindow),
("point" , Builtin_Extra Point), ("point" , Builtin_Extra Point),
("color" , Builtin_Extra Color), ("rgb" , Builtin_Extra (Color False)),
("rgba" , Builtin_Extra (Color True)),
("texture" , Builtin_Extra Texture), ("texture" , Builtin_Extra Texture),
("texbind" , Builtin_Extra BindTexture),
("texpoint" , Builtin_Extra TextureCoord),
("draw" , Builtin_Extra Draw), ("draw" , Builtin_Extra Draw),
("def" , Builtin_Def ), ("def" , Builtin_Def ),
...@@ -81,7 +118,7 @@ dict = fromAList $ map (second StackBuiltin) $ ...@@ -81,7 +118,7 @@ dict = fromAList $ map (second StackBuiltin) $
("delete" , Builtin_Delete ), ("delete" , Builtin_Delete ),
("keys" , Builtin_Keys )] ("keys" , Builtin_Keys )]
fromStack (StackSymbol x) = read x :: GL.GLdouble fromStack (StackSymbol x) = read x :: GL.GLfloat
fromStack (StackInt n) = fromIntegral n fromStack (StackInt n) = fromIntegral n
fromStack _ = undefined fromStack _ = undefined
...@@ -116,9 +153,14 @@ runLogos OpenWindow = do ...@@ -116,9 +153,14 @@ runLogos OpenWindow = do
case st of case st of
StackInt h:StackInt w:st' -> do StackInt h:StackInt w:st' -> do
runStackState $ put st' runStackState $ put st'
liftIO $ do void $ liftIO $ do
void $ GLFW.openWindow (GL.Size (fromIntegral w) (fromIntegral h)) [GLFW.DisplayRGBBits 8 8 8, GLFW.DisplayAlphaBits 8] GLFW.Window 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 _ -> unit
runLogos Point = do runLogos Point = do
st <- runStackState get st <- runStackState get
...@@ -126,18 +168,58 @@ runLogos Point = do ...@@ -126,18 +168,58 @@ runLogos Point = do
(fromStack -> z):(fromStack -> y):(fromStack -> x):st' -> do (fromStack -> z):(fromStack -> y):(fromStack -> x):st' -> do
runStackState $ put $ StackExtra (Opaque (P (GL.Vertex3 x y z))):st' runStackState $ put $ StackExtra (Opaque (P (GL.Vertex3 x y z))):st'
_ -> unit _ -> unit
runLogos Color = do runLogos (Color isRGBA) = do
st <- runStackState get st <- runStackState get
case st of case st of
(fromStack -> b):(fromStack -> g):(fromStack -> r):st' -> do (fromStack -> a):(fromStack -> b):(fromStack -> g):(fromStack -> r):st' | isRGBA -> do
runStackState $ put $ StackExtra (Opaque (C (GL.Color3 r g b))):st' 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 _ -> unit
runLogos Texture = do runLogos TextureCoord = do
st <- runStackState get st <- runStackState get
case st of case st of
(fromStack -> y):(fromStack -> x):st' -> do (fromStack -> y):(fromStack -> x):st' -> do
runStackState $ put $ StackExtra (Opaque (T (GL.TexCoord2 x y))):st' runStackState $ put $ StackExtra (Opaque (T (GL.TexCoord2 x y))):st'
_ -> unit _ -> 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 runLogos Draw = do
st <- runStackState get st <- runStackState get
case st of case st of
...@@ -149,26 +231,90 @@ runLogos Draw = do ...@@ -149,26 +231,90 @@ runLogos Draw = do
"triangles" -> GL.Triangles "triangles" -> GL.Triangles
"points" -> GL.Points "points" -> GL.Points
_ -> GL.Points _ -> GL.Points
GL.renderPrimitive mode $ for_ l $ \case extras = [x | StackExtra (Opaque x) <- l]
StackExtra (Opaque (P v)) -> GL.vertex v fullVertices = go zacc extras
StackExtra (Opaque (C c)) -> GL.color c where zacc = (GL.Color4 0 0 0 0,GL.TexCoord2 0 0)
StackExtra (Opaque (T t)) -> GL.texCoord t go (c,tx) (P v:t) = (c,tx,v):go zacc t
_ -> unit 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 GLFW.swapBuffers
_ -> unit _ -> 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 main = do
putStrLn "Initializing graphical environment..." putStrLn "Initializing graphical environment..."
between (void GLFW.initialize) GLFW.terminate $ do 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 args <- getArgs
prelude <- fold <$> for args readString prelude <- fold <$> for args readString
putStrLn "Hello from Logos !"
text <- readHString stdin text <- readHString stdin
let go (w:ws) = do let go (w:ws) = do
execSymbol runLogos (\_ -> unit) w execSymbol runLogos (\_ -> unit) w
......
...@@ -12,7 +12,7 @@ build-type: Simple ...@@ -12,7 +12,7 @@ build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
executable logos 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 default-extensions: TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies, TupleSections, MultiParamTypeClasses, Rank2Types, AllowAmbiguousTypes, RoleAnnotations, ViewPatterns, LambdaCase
hs-source-dirs: exe hs-source-dirs: exe
main-is: Logos.hs main-is: Logos.hs
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment