From aa8da038f9ab19996436b6a9cf213445de9ef3d7 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 7 Jun 2023 14:11:17 +1200 Subject: [PATCH] Now I'm having trouble with GLUT in test program, switch back to SDL2 this time without GL. --- app/Main.hs | 213 +++++++++++++------------------------------------- cattrap.cabal | 2 +- 2 files changed, 55 insertions(+), 160 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index bcb3e30..7f5b0e5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where +import System.Environment (getArgs) import Text.XML.Light.Input (parseXMLDoc) import qualified Text.XML.Light.Types as X import Data.Maybe (fromJust, fromMaybe) @@ -17,19 +19,23 @@ import Stylist.Tree (StyleTree(..)) import Stylist (PropertyParser(..)) import Data.CSS.Syntax.Tokens (Token(..), tokenize) -import Graphics.UI.GLUT -import Graphics.GL.Core32 - -import Foreign.Ptr (castPtr, nullPtr) -import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (withArrayLen, allocaArray, peekArray) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Utils (with) -import Foreign.C.String (withCString) +import SDL hiding (rotate) +import Foreign.C.Types (CInt) +import Data.Function (fix) +import Control.Monad (unless) main :: IO () main = do - (progname, args) <- getArgsAndInitialize + SDL.initializeAll + + let wcfg = defaultWindow { + windowInitialSize = V2 640 480, + windowResizable = True + } + w <- createWindow "CatTrap" wcfg + renderer <- createRenderer w (-1) defaultRenderer + + args <- getArgs source <- readFile $ case args of (filename:_) -> filename [] -> "styletree.xml" @@ -37,30 +43,19 @@ main = do let styles = xml2styles temp xml let layout = finalizeCSS' placeholderFont styles - w <- createWindow progname - - vertexShader <- compileOGLShader vertexSource GL_VERTEX_SHADER - fragmentShader <- compileOGLShader fragmentSource GL_FRAGMENT_SHADER - shader <- compileOGLProgram [] [vertexShader, fragmentShader] - glDetachShader shader vertexShader - glDetachShader shader fragmentShader - glDeleteShader vertexShader - glDeleteShader fragmentShader + fix $ \loop -> do + events <- fmap eventPayload <$> pollEvents + rendererDrawColor renderer $= V4 255 255 255 255 + clear renderer - displayCallback $= do - clear [ ColorBuffer ] - Size x y <- get windowSize + V2 x y <- get $ windowSize w let (display:_) = boxLayout zeroBox { B.size = B.Size (fromIntegral x) (fromIntegral y) } layout False + renderDisplay renderer display - glUseProgram shader - attribScale <- withCString "windowsize" $ glGetUniformLocation shader - glUniform3f attribScale (realToFrac x) (realToFrac y) 1 - - renderDisplay shader display - flush - mainLoop + present renderer + unless (QuitEvent `elem` events) loop xml2styles :: CSSBox Nil -> X.Element -> StyleTree (CSSBox Nil) xml2styles parent el = StyleTree { @@ -78,138 +73,38 @@ instance PropertyParser Nil where inherit _ = Nil longhand _ _ _ _ = Nothing -renderDisplay :: Eq a => GLuint -> LayoutItem Double Double ((Double, Double), a) +renderDisplay :: Renderer -> LayoutItem Double Double ((Double, Double), Nil) -> IO () -renderDisplay shader display = do +renderDisplay renderer display = do let ((x, y), _) = layoutGetInner display let box = layoutGetBox display - attribColour <- withCString "fill" $ glGetUniformLocation shader - - glUniform3f attribColour 1 0 0 - drawBox x y (B.width box) (B.height box) - glUniform3f attribColour 0 1 0 - drawBox (x + B.left (B.margin box)) (y + B.top (B.margin box)) - (B.width box - B.left (B.margin box) - B.right (B.margin box)) - (B.height box - B.top (B.margin box) - B.bottom (B.margin box)) - glUniform3f attribColour 0 0 1 - drawBox (x + B.left (B.margin box) + B.left (B.border box)) - (y + B.top (B.margin box) + B.top (B.border box)) - (B.inline (B.size box) + B.left (B.padding box) + B.right (B.padding box)) - (B.block (B.size box) + B.top (B.padding box) + B.bottom (B.padding box)) - glUniform3f attribColour 1 1 0 - drawBox (x + B.left (B.margin box) + B.left (B.border box) + B.left (B.padding box)) - (y + B.top (B.margin box) + B.top (B.border box) + B.top (B.padding box)) - (B.inline $ B.size box) (B.block $ B.size box) - - mapM (renderDisplay shader) $ layoutGetChilds display + + rendererDrawColor renderer $= V4 255 0 0 255 + drawBox renderer x y (B.width box) (B.height box) + rendererDrawColor renderer $= V4 0 255 0 255 + drawBox renderer + (x + B.left (B.margin box)) (y + B.top (B.margin box)) + (B.width box - B.left (B.margin box) - B.right (B.margin box)) + (B.height box - B.top (B.margin box) - B.bottom (B.margin box)) + rendererDrawColor renderer $= V4 0 0 255 255 + drawBox renderer + (x + B.left (B.margin box) + B.left (B.border box)) + (y + B.top (B.margin box) + B.top (B.border box)) + (B.inline (B.size box) + B.left (B.padding box) + B.right (B.padding box)) + (B.block (B.size box) + B.top (B.padding box) + B.bottom (B.padding box)) + rendererDrawColor renderer $= V4 255 255 0 255 + drawBox renderer + (x + B.left (B.margin box) + B.left (B.border box) + B.left (B.padding box)) + (y + B.top (B.margin box) + B.top (B.border box) + B.top (B.padding box)) + (B.inline $ B.size box) (B.block $ B.size box) + + mapM (renderDisplay renderer) $ layoutGetChilds display return () -drawBox x y width height = do - buf <- withPointer $ glGenBuffers 1 - glBindBuffer GL_ARRAY_BUFFER buf - glBufferData' GL_ARRAY_BUFFER [ - x, y, 0, - x + width, y, 0, - x, y + height, 0, - - x + width, y, 0, - x + width, y + height, 0, - x, y + height, 0 - ] GL_STATIC_DRAW - - glEnableVertexAttribArray 0 - glBindBuffer GL_ARRAY_BUFFER buf - glVertexAttribPointer 0 3 GL_FLOAT GL_FALSE 0 nullPtr - - glDrawArrays GL_TRIANGLES 0 6 - glDisableVertexAttribArray 0 - -withPointer cb = alloca $ \ret' -> do - cb ret' - peek ret' - -glBufferData' _ [] _ = return () -glBufferData' target dat usage = - withArrayLen (map realToFrac dat :: [Float]) $ \len dat' -> do - glBufferData target (toEnum $ len*sizeOf (head dat)) (castPtr dat') usage - -compileOGLShader :: String -> GLenum -> IO GLuint -compileOGLShader src shType = do - shader <- glCreateShader shType - if shader == 0 - then error "Could not create shader" - else do - success <-do - withCString (src) $ \ptr -> - with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr - - glCompileShader shader - with (0 :: GLint) $ \ptr -> do - glGetShaderiv shader GL_COMPILE_STATUS ptr - peek ptr - - if success == GL_FALSE - then do - err <- do - infoLog <- with (0 :: GLint) $ \ptr -> do - glGetShaderiv shader GL_INFO_LOG_LENGTH ptr - logsize <- peek ptr - allocaArray (fromIntegral logsize) $ \logptr -> do - glGetShaderInfoLog shader logsize nullPtr logptr - peekArray (fromIntegral logsize) logptr - - return $ unlines [ "Could not compile shader:" - , src - , map (toEnum . fromEnum) infoLog - ] - error err - else return shader - -compileOGLProgram :: [(String, Integer)] -> [GLuint] -> IO GLuint -compileOGLProgram attribs shaders = do - (program, success) <- do - program <- glCreateProgram - forM_ shaders (glAttachShader program) - forM_ attribs - $ \(name, loc) -> - withCString name - $ glBindAttribLocation program - $ fromIntegral loc - glLinkProgram program - - success <- with (0 :: GLint) $ \ptr -> do - glGetProgramiv program GL_LINK_STATUS ptr - peek ptr - return (program, success) - - if success == GL_FALSE - then with (0 :: GLint) $ \ptr -> do - glGetProgramiv program GL_INFO_LOG_LENGTH ptr - logsize <- peek ptr - infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do - glGetProgramInfoLog program logsize nullPtr logptr - peekArray (fromIntegral logsize) logptr - error $ unlines - [ "Could not link program" - , map (toEnum . fromEnum) infoLog - ] - else do - forM_ shaders glDeleteShader - return program - -vertexSource = unlines [ - "#version 330 core", - "layout(location = 0) in vec3 vertexPositionModelSpace;", - "uniform vec3 windowsize;", - "void main() {", - "gl_Position.xyz = vertexPositionModelSpace/windowsize - 1;", - "gl_Position.y = -gl_Position.y;", - "gl_Position.w = 1.0;", - "}" - ] -fragmentSource = unlines [ - "#version 330 core", - "uniform vec3 fill;", - "out vec3 colour;", - "void main() { colour = fill; }" - ] +drawBox :: Renderer -> Double -> Double -> Double -> Double -> IO () +drawBox renderer x y width height = do + fillRect renderer $ Just $ Rectangle + (P $ V2 (c x) (c y)) (V2 (c width) (c height)) + +c :: (Enum a, Enum b) => a -> b +c = toEnum . fromEnum diff --git a/cattrap.cabal b/cattrap.cabal index 9fe81c3..e146c56 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -43,7 +43,7 @@ executable cattrap main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.16, cattrap, xml, text, css-syntax, stylist-traits, GLUT, gl + build-depends: base >=4.12 && <4.16, cattrap, xml, text, css-syntax, stylist-traits, sdl2 >= 2.5.4 hs-source-dirs: app default-language: Haskell2010 -- 2.30.2