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
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
......
......@@ -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
......
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