Commit 17bb12a7 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Fun with Logos: implement various builtins

parent a074f5ce
{-# LANGUAGE DeriveGeneric, TypeFamilies, ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric, TypeFamilies, ScopedTypeVariables, ExistentialQuantification, PatternSynonyms #-}
module Main where
import Definitive
......@@ -14,7 +14,9 @@ import Data.StateVar (($=))
import Foreign.Storable
import Foreign.Ptr
import Control.Exception (SomeException(..),Exception)
import GHC.Generics
import GHC.Generics (Generic)
import Data.Matricial
import Language.Parser
stringWords :: String -> [String]
stringWords = map fromString . fromBlank
......@@ -31,14 +33,25 @@ stringWords = map fromString . fromBlank
| otherwise = fromWChar (k.(c:)) t
fromWChar k "" = [k ""]
data LogosBuiltin = Wait | Quit | Format | Print | OpenWindow | Point | Color Bool | Texture | TextureCoord | Draw | BindTexture
data LogosBuiltin = Wait | Quit | Format | Print | OpenWindow | Texture | BuildMesh | Draw
| VCons | MCons | Rotation | Translation | Skew | Ejection | MCompose | MAdd
deriving Show
-- data VertexInfo = VertexInfo !(GL.Vector3 GL.GLfloat) !(GL.Color4 GL.GLfloat) !(GL.TexCoord2 GL.GLfloat)
-- data Mesh = Mesh GL.PrimitiveMode [VertexInfo]
-- data Scene = OriginMesh Mesh | Subscenes [TransformedScene]
-- type TransformedScene = ([Transform],Scene)
toFloat (StackInt n) = Just (fromIntegral n)
toFloat (StackSymbol s) = matches Just readable s
toFloat (StackExtra (Opaque (F f))) = Just f
toFloat x = Nothing
data LogosData = P (GL.Vertex3 GL.GLfloat) | C (GL.Color4 GL.GLfloat) | T (GL.TexCoord2 GL.GLfloat) | TI GL.TextureObject
pattern StackFloat f <- (toFloat -> Just f)
pattern StackVect v = StackExtra (Opaque (V v))
pattern StackMat m = StackExtra (Opaque (M m))
data LogosData = F GL.GLfloat
| V (V4 GL.GLfloat)
| M (Mat Four Four GL.GLfloat)
| Mesh GL.PrimitiveMode Int [(String,Int,GL.BufferObject)]
| TI GL.TextureObject
deriving Show
data LogosState = LogosState {
_running :: Bool
......@@ -46,19 +59,24 @@ data LogosState = LogosState {
running :: Lens' LogosState Bool
running = lens _running (\x y -> x { _running = y })
dict = fromAList $ map (second StackBuiltin) $
[("wait" , Builtin_Extra Wait ),
("quit" , Builtin_Extra Quit ),
("format" , Builtin_Extra Format),
("print" , Builtin_Extra Print ),
("window" , Builtin_Extra OpenWindow),
("point" , Builtin_Extra Point),
("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),
dict = fromAList $
map (second StackBuiltin)
[("wait" , Builtin_Extra Wait ),
("quit" , Builtin_Extra Quit ),
("format" , Builtin_Extra Format),
("vcons" , Builtin_Extra VCons),
("mcons" , Builtin_Extra MCons),
("rotation" , Builtin_Extra Rotation),
("translation" , Builtin_Extra Translation),
("**" , Builtin_Extra MCompose),
("++" , Builtin_Extra MAdd),
("skew" , Builtin_Extra Skew),
("ejection" , Builtin_Extra Ejection),
("print" , Builtin_Extra Print),
("window" , Builtin_Extra OpenWindow),
("texture" , Builtin_Extra Texture),
("mesh" , Builtin_Extra BuildMesh),
("draw" , Builtin_Extra Draw),
("def" , Builtin_Def ),
("$" , Builtin_DeRef ),
......@@ -109,6 +127,39 @@ runLogos Wait = do
runStackState $ put st'
_ -> unit
runLogos Quit = runExtraState $ do running =- False
runLogos VCons = runStackState $ modify $ \case
StackFloat w:StackFloat z:StackFloat y:StackFloat x:st -> StackVect (V4 x y z w):st
st -> st
runLogos MCons = runStackState $ modify $ \case
StackVect w:StackVect z:StackVect y:StackVect x:st -> StackMat (V4 x y z w):st
st -> st
runLogos Rotation = runStackState $ modify $ \case
StackVect u:StackVect v:st -> StackMat (rotation v u):st
st -> st
runLogos Translation = runStackState $ modify $ \case
StackVect (V4 x y z _):st -> StackMat (translation (V3 x y z)):st
st -> st
runLogos Ejection = runStackState $ modify $ \case
StackVect v:st -> StackMat (ejection v):st
st -> st
runLogos Skew = runStackState $ modify $ \case
StackVect v:st -> StackMat (skew v):st
st -> st
runLogos MAdd = runStackState $ modify $ \case
StackMat m:StackMat m':st -> StackMat (m+m'):st
StackVect v:StackVect v':st -> StackVect (v+v'):st
StackFloat f:StackFloat f':st -> StackExtra (Opaque $ F $ f+f'):st
st -> st
runLogos MCompose = runStackState $ modify $ \case
StackMat m':StackMat m:st -> StackMat (m'$*m):st
StackMat m:StackVect v:st -> StackVect (v & from scalar %~ ($*m)):st
StackVect v:StackMat m:st -> StackVect (v & from scalar %~ ($*m)):st
StackVect v:StackVect v':st -> StackExtra (Opaque $ F $ scalProd v v'):st
StackFloat f:StackVect v:st -> StackVect (pure f * v):st
StackVect v:StackFloat f:st -> StackVect (pure f * v):st
StackFloat f:StackMat m:st -> StackMat (map2 (f*) m):st
StackMat m:StackFloat f:st -> StackMat (map2 (f*) m):st
st -> st
runLogos Format = do
st <- runStackState get
case st of
......@@ -141,34 +192,6 @@ runLogos OpenWindow = do
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
case st of
(fromStack -> z):(fromStack -> y):(fromStack -> x):st' -> do
runStackState $ put $ StackExtra (Opaque (P (GL.Vertex3 x y z))):st'
_ -> unit
runLogos (Color isRGBA) = do
st <- runStackState get
case st of
(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 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
......@@ -199,57 +222,61 @@ runLogos Texture = do
_ -> unit
runLogos Draw = do
runLogos BuildMesh = do
st <- runStackState get
case st of
StackSymbol s:StackList l:st' -> do
runStackState $ put st'
liftIO $ do
StackSymbol s:StackList attribs:StackList props:st' -> do
m <- liftIO $ do
let mode = case s of
"lines" -> GL.Lines
"triangles" -> GL.Triangles
"points" -> GL.Points
"LINES" -> GL.Lines
"TRIANGLES" -> GL.Triangles
"POINTS" -> GL.Points
_ -> GL.Points
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
fullVertices = deZip $ traverse Zip [[v | StackVect v <- vs] | StackList vs <- props]
newVec f l = GL.genObjectName <*= \vb -> do
let vs = V.unfoldr (\case
h:t -> Just (f h,t)
[] -> Nothing) fullVertices
[] -> Nothing) l
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)
vecs <- sequence (zap [let run = case n of
1 -> newVec (\(V4 x _ _ _) -> V1 x)
2 -> newVec (\(V4 x y _ _) -> V2 x y)
3 -> newVec (\(V4 x y z _) -> V3 x y z)
4 -> newVec id
_ -> error $ "Invalid attribute size "+show n+" (must be between 1 and 4)"
in \l -> run l <&> (s,n,)
| StackList [StackSymbol s,StackInt n] <- attribs] fullVertices)
return (Mesh mode (length (head fullVertices)) vecs)
runStackState $ put (StackExtra (Opaque m):st')
_ -> unit
runLogos Draw = do
st <- runStackState get
case st of
StackExtra (Opaque (Mesh mode size vecs)):st' -> do
runStackState $ put st'
liftIO $ do
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)
let withAttrib (name,sz,vec) go = do
l <- SV.get (GL.attribLocation prog name)
between (GL.vertexAttribArray l $= GL.Enabled) (GL.vertexAttribArray l $= GL.Disabled) $ do
GL.bindBuffer GL.ArrayBuffer $= Just vec
GL.vertexAttribPointer l $= (GL.ToFloat, GL.VertexArrayDescriptor (fromIntegral sz) GL.Float 0 nullPtr)
go
GL.clear [ GL.DepthBuffer, GL.ColorBuffer ]
composing withAttrib vecs $ do
GL.drawArrays mode 0 (fromIntegral size)
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
......@@ -303,6 +330,17 @@ main = do
(go (stringWords (prelude + " " + text))^..stateT.concatT) (defaultState dict (LogosState True))
instance Storable (Vec Zero a) where
sizeOf _ = zero
alignment _ = 1
peek p = return V0
poke _ _ = unit
instance (Storable a,Storable (Vec n a)) => Storable (Vec (Succ n) a) where
sizeOf ~(VS x v) = sizeOf x + sizeOf v
alignment ~(VS x v) = alignment x
peek p = peek (castPtr p) <&> uncurry VS
poke p (VS x v) = poke (castPtr p) (x,v)
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))
......
......@@ -19,7 +19,7 @@ library
default-language: Haskell2010
executable logos
build-depends: base >=4.8 && <4.10, definitive-base >=2.6 && <2.7, capricon, OpenGL, GLFW, StateVar, JuicyPixels, vector, logos
build-depends: base >=4.8 && <4.10, definitive-base >=2.6 && <2.7, capricon, OpenGL, GLFW, StateVar, JuicyPixels, vector, logos, definitive-parser
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