Compare commits

...

3 commits

Author SHA1 Message Date
nek0 1acf7f2a0f throw out more of GLUtil 2020-05-13 05:42:32 +02:00
nek0 4b37d5f51c start getting rid of GLUtil 2020-05-13 04:21:49 +02:00
nek0 d73c854999 black screen? 2020-02-10 00:35:28 +01:00
10 changed files with 194 additions and 214 deletions

View file

@ -8,7 +8,6 @@ import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL as GLRaw import qualified Graphics.GL as GLRaw
import qualified Graphics.GLUtil as GLU
import Codec.Picture import Codec.Picture
@ -58,12 +57,15 @@ main =
preLoopImpl :: Affection UserData () preLoopImpl :: Affection UserData ()
preLoopImpl = liftIO $ do preLoopImpl = liftIO $ do
void $ SDL.setMouseLocationMode SDL.RelativeLocation void $ SDL.setMouseLocationMode SDL.RelativeLocation
-- GL.depthFunc $= Just GL.Less GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) GL.frontFace $= GL.CCW
GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge) GL.blend $= GL.Enabled
GL.texture GL.Texture2D $= GL.Enabled GL.depthFunc $= Nothing
-- GL.frontFace $= GL.CW GL.scissor $= Nothing
GL.viewport $= (GL.Position 0 0, GL.Size 1920 1080) GL.viewport $= (GL.Position 0 0, GL.Size 1920 1080)
GL.clearColor $= GL.Color4 1 1 1 1
loadStateImpl :: IO UserData loadStateImpl :: IO UserData
loadStateImpl = do loadStateImpl = do

View file

@ -6,7 +6,7 @@ import SDL (($=))
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL.Functions as GLRaw (glVertexAttribDivisor) import qualified Graphics.GL.Functions as GLRaw (glVertexAttribDivisor)
import qualified Graphics.GLUtil as GLU -- import qualified Graphics.GLUtil as GLU
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@ -101,10 +101,50 @@ rawVertices =
] ]
initSpriteShaderObjects = do initSpriteShaderObjects = do
-- vertexShaderSrc <- BS.readFile "shader/vertex.sl"
-- fragmentShaderSrc <- BS.readFile "shader/fragment.sl"
vertexShader <- createShader VertexShader
fragmentShader <- createShader FragmentShader
vertexShaderSrc <- BS.readFile "shader/vertex.sl" vertexShaderSrc <- BS.readFile "shader/vertex.sl"
fragmentShaderSrc <- BS.readFile "shader/fragment.sl" fragmentShaderSrc <- BS.readFile "shader/fragment.sl"
shaderProgram <- GLU.simpleShaderProgramBS vertexShaderSrc fragmentShaderSrc shaderSourceBS vertexShader $= vertexShaderSrc
shaderSourceBS fragmentShader $= fragmentShaderSrc
compileShader vertexShader
get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
vOK <- get (compileStatus vertexShader)
infoLog <- get (shaderInfoLog vertexShader)
unless (null infoLog || infoLog == "\NUL")
(mapM_
putStrLn
["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
)
unless vOK $ do
deleteObjectName vertexShader
ioError (userError "vertexShader compilation failed")
compileShader fragmentShader
get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
fOK <- get (compileStatus fragmentShader)
infoLog <- get (shaderInfoLog fragmentShader)
unless (null infoLog || infoLog == "\NUL")
(mapM_
putStrLn
["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
)
unless fOK $ do
deleteObjectName fragmentShader
ioError (userError "fragmentShader compilation failed")
-- shaderProgram <- GLU.simpleShaderProgramBS vertexShaderSrc fragmentShaderSrc
shaderProgram <- createProgram
attachShaders shaderProgram $= [vertexShader, fragmentShader]
linkProgram shaderProgram
get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
return (SpriteShaderObjects shaderProgram) return (SpriteShaderObjects shaderProgram)
@ -149,6 +189,12 @@ loadSprites amount = do
-- [ (V2 0 0) -- [ (V2 0 0)
-- ] -- ]
GL.texture GL.Texture2D $= GL.Enabled
GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge)
GL.textureFilter GL.Texture2D $= ((GL.Nearest, Just GL.Nearest), GL.Nearest)
GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)
GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)
textObj <- initSpriteTextureObjects lookups textObj <- initSpriteTextureObjects lookups
positions <- replicateM amount $ do positions <- replicateM amount $ do

View file

@ -4,3 +4,4 @@ module Types
import Types.UserData as T import Types.UserData as T
import Types.Sprite as T import Types.Sprite as T
import Types.CanvasShader as T

26
app/Types/CanvasShader.hs Normal file
View file

@ -0,0 +1,26 @@
module Types.CanvasShader where
import Data.List as L
import Data.Map.Strict
import Graphics.Rendering.OpenGL (get)
import qualified Graphics.Rendering.OpenGL as GL
data CanvasShader = CanvasShader
{ shaderAttribs :: Map String (GL.AttribLocation, GL.VariableType)
, shaderUniforms :: Map String (GL.UniformLocation, GL.VariableType)
, shaderProgram :: GL.Program
}
makeCanvasShader :: GL.Program -> IO CanvasShader
makeCanvasShader p = CanvasShader
<$> (fromList <$> ((get (GL.activeAttribs p) >>= mapM (aux (GL.attribLocation p)))))
<*> (fromList <$> ((get (GL.activeUniforms p)
>>= mapM (aux (GL.uniformLocation p) . on3 trimArray))))
<*> (pure p)
where aux f (_,t,name) = get (f name) >>= \l -> return (name, (l, t))
on3 f (a,b,c) = (a, b, f c)
-- An array uniform, foo, is sometimes given the name "foo" and
-- sometimes the name "foo[0]". We strip off the "[0]" if present.
trimArray n = if "[0]" `isSuffixOf` n then L.take (length n - 3) n else n

View file

@ -1,18 +1,29 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Types.Sprite where module Types.Sprite where
import Data.Maybe (maybe)
import qualified Data.Map.Strict as M
import SDL (get, ($=)) import SDL (get, ($=))
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU import qualified Graphics.GL.Core33 as GLRaw
-- import qualified Graphics.GLUtil as GLU
import Codec.Picture import Codec.Picture
import Linear import Linear
import Foreign.Ptr
import Foreign.Marshal.Utils (with)
import Unsafe.Coerce (unsafeCoerce)
-- internal imports -- internal imports
import Classes.Renderable import Classes.Renderable
import Types.CanvasShader
data SpriteRenderObjects = SpriteRenderObjects data SpriteRenderObjects = SpriteRenderObjects
{ roVAO :: GL.VertexArrayObject { roVAO :: GL.VertexArrayObject
@ -20,7 +31,7 @@ data SpriteRenderObjects = SpriteRenderObjects
} }
data SpriteShaderObjects = SpriteShaderObjects data SpriteShaderObjects = SpriteShaderObjects
{ soProgram :: GLU.ShaderProgram { soProgram :: CanvasShader
} }
data Sprite = Sprite data Sprite = Sprite
@ -35,20 +46,19 @@ instance Renderable Sprite where
init init
(SpriteRenderObjects vao vbo) (SpriteRenderObjects vao vbo)
(SpriteShaderObjects prog) (SpriteShaderObjects (CanvasShader att uni prog))
texture texture
_ = do _ = do
GL.currentProgram $= Just (GLU.program prog) GL.currentProgram $= Just prog
GL.bindVertexArrayObject $= Just vao GL.bindVertexArrayObject $= Just vao
GL.activeTexture $= GL.TextureUnit 0 GL.activeTexture $= GL.TextureUnit 0
GL.textureBinding GL.Texture2D $= Just texture GL.textureBinding GL.Texture2D $= Just texture
GL.clearColor $= GL.Color4 1 1 1 1
-- let projection = ortho (-960) 960 (-540) 540 (-1) 1 :: M44 Float -- let projection = ortho (-960) 960 (-540) 540 (-1) 1 :: M44 Float
-- GLU.setUniform prog "projection" (projection) -- GLU.setUniform prog "projection" (projection)
draw draw
(SpriteRenderObjects vao vbo) (SpriteRenderObjects vao vbo)
(SpriteShaderObjects prog) (SpriteShaderObjects (CanvasShader att uni prog))
(Sprite pos@(V2 px py) size) = do (Sprite pos@(V2 px py) size) = do
let (V2 sx sy) = fmap fromIntegral size let (V2 sx sy) = fmap fromIntegral size
model = fmap (fmap fromIntegral) $ V4 model = fmap (fmap fromIntegral) $ V4
@ -59,8 +69,15 @@ instance Renderable Sprite where
:: M44 Float :: M44 Float
projection = ortho (-960) 960 (-540) 540 (-1) 1 projection = ortho (-960) 960 (-540) 540 (-1) 1
-- putStrLn $ show model -- putStrLn $ show model
GLU.setUniform prog "pm" (projection !*! model) maybe
(const (putStrLn warn >> return ()))
(flip asUniform . fst)
(M.lookup "pm" uni)
(projection !*! model)
GL.drawArrays GL.Triangles 0 6 GL.drawArrays GL.Triangles 0 6
where
warn = "WARNING: uniform pm is not active"
v `asUniform` loc = with v $ GLRaw.glUniformMatrix4fv (unsafeCoerce loc) 1 1 . castPtr
clean _ = do clean _ = do
GL.currentProgram $= (Nothing :: Maybe GL.Program) GL.currentProgram $= (Nothing :: Maybe GL.Program)

View file

@ -45,11 +45,11 @@ data Subsystems = Subsystems
, subMouse :: SubMouse , subMouse :: SubMouse
} }
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
instance Participant SubWindow UserData where instance Participant SubWindow where
type Mesg SubWindow UserData = WindowMessage type Mesg SubWindow = WindowMessage
partSubscribers (SubWindow t) = genericSubscribers t partSubscribers (SubWindow t) = genericSubscribers t
@ -57,11 +57,11 @@ instance Participant SubWindow UserData where
partUnSubscribe (SubWindow t) = genericUnSubscribe t partUnSubscribe (SubWindow t) = genericUnSubscribe t
instance SDLSubsystem SubWindow UserData where instance SDLSubsystem SubWindow where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant SubMouse UserData where instance Participant SubMouse where
type Mesg SubMouse UserData = MouseMessage type Mesg SubMouse = MouseMessage
partSubscribers (SubMouse t) = genericSubscribers t partSubscribers (SubMouse t) = genericSubscribers t
@ -69,29 +69,29 @@ instance Participant SubMouse UserData where
partUnSubscribe (SubMouse t) = genericUnSubscribe t partUnSubscribe (SubMouse t) = genericUnSubscribe t
instance SDLSubsystem SubMouse UserData where instance SDLSubsystem SubMouse where
consumeSDLEvents = consumeSDLMouseEvents consumeSDLEvents = consumeSDLMouseEvents
genericSubscribers genericSubscribers
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> Affection UserData [(msg -> Affection UserData ())] -> Affection [(msg -> Affection ())]
genericSubscribers t = do genericSubscribers t = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
genericSubscribe genericSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection UserData ()) -> (msg -> Affection ())
-> Affection UserData UUID -> Affection UUID
genericSubscribe t funct = do genericSubscribe t funct = do
uu <- genUUID uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :) liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu return uu
genericUnSubscribe genericUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> UUID -> UUID
-> Affection UserData () -> Affection ()
genericUnSubscribe t uu = genericUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where where

View file

@ -26,12 +26,11 @@ executable canvas
Renderer Renderer
-- other-extensions: -- other-extensions:
ghc-options: -Wall ghc-options: -Wall
build-depends: base ^>=4.12.0.0 build-depends: base >= 4.12.0.0 && < 5
, affection , affection
, sdl2 ^>=2.5.0.0 , sdl2 ^>=2.5.0.0
, OpenGL , OpenGL
, OpenGLRaw , OpenGLRaw
, GLUtil
, JuicyPixels , JuicyPixels
, JuicyPixels-extra , JuicyPixels-extra
, stm , stm

View file

@ -1,45 +0,0 @@
{
"affection": {
"branch": "master",
"description": "A simple Game Engine in Haskell using SDL",
"homepage": "",
"owner": "nek0",
"repo": "affection",
"rev": "18775515d8d569c36148c02a134e1f538981b1ff",
"sha256": "09bxf917mj1lanc0d5f7xj3n22dk8drzgqivqpnvskdx88pmrv4k",
"type": "tarball",
"url": "https://github.com/nek0/affection/archive/18775515d8d569c36148c02a134e1f538981b1ff.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"ghc": {
"sha256": "1pqlx6rdjs2110g0y1i9f8x18lmdizibjqd15f5xahcz39hgaxdw",
"type": "file",
"url": "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz",
"url_template": "https://downloads.haskell.org/~ghc/<version>/ghc-<version>-x86_64-deb9-linux.tar.xz",
"version": "8.6.5"
},
"niv": {
"branch": "master",
"description": "Easy dependency management for Nix projects",
"homepage": "https://github.com/nmattia/niv",
"owner": "nmattia",
"repo": "niv",
"rev": "7a21f49027c0901456acd6e61d91bd9e3b15b1f6",
"sha256": "1hrcjgz4ib5n6wm96gcjk2qjl03pvspksk48b2lkn29vpdry98jm",
"type": "tarball",
"url": "https://github.com/nmattia/niv/archive/7a21f49027c0901456acd6e61d91bd9e3b15b1f6.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {
"branch": "nixos-19.09",
"description": "A read-only mirror of NixOS/nixpkgs tracking the released channels. Send issues and PRs to",
"homepage": "https://github.com/NixOS/nixpkgs",
"owner": "NixOS",
"repo": "nixpkgs-channels",
"rev": "d3d2de8b99be56c5a6ed18f46e280f8103124dd7",
"sha256": "1chzbajrspw24csnv2c0h1h59pbp1k6939cllmd61382p9iw7rg8",
"type": "tarball",
"url": "https://github.com/NixOS/nixpkgs-channels/archive/d3d2de8b99be56c5a6ed18f46e280f8103124dd7.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}

View file

@ -1,134 +0,0 @@
# This file has been generated by Niv.
let
#
# The fetchers. fetch_<type> fetches specs of type <type>.
#
fetch_file = pkgs: spec:
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; }
else
pkgs.fetchurl { inherit (spec) url sha256; };
fetch_tarball = pkgs: spec:
if spec.builtin or true then
builtins_fetchTarball { inherit (spec) url sha256; }
else
pkgs.fetchzip { inherit (spec) url sha256; };
fetch_git = spec:
builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
fetch_builtin-tarball = spec:
builtins.trace
''
WARNING:
The niv type "builtin-tarball" will soon be deprecated. You should
instead use `builtin = true`.
$ niv modify <package> -a type=tarball -a builtin=true
''
builtins_fetchTarball { inherit (spec) url sha256; };
fetch_builtin-url = spec:
builtins.trace
''
WARNING:
The niv type "builtin-url" will soon be deprecated. You should
instead use `builtin = true`.
$ niv modify <package> -a type=file -a builtin=true
''
(builtins_fetchurl { inherit (spec) url sha256; });
#
# Various helpers
#
# The set of packages used when specs are fetched using non-builtins.
mkPkgs = sources:
let
sourcesNixpkgs =
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
hasThisAsNixpkgsPath = <nixpkgs> == ./.;
in
if builtins.hasAttr "nixpkgs" sources
then sourcesNixpkgs
else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
import <nixpkgs> {}
else
abort
''
Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
add a package called "nixpkgs" to your sources.json.
'';
# The actual fetching function.
fetch = pkgs: name: spec:
if ! builtins.hasAttr "type" spec then
abort "ERROR: niv spec ${name} does not have a 'type' attribute"
else if spec.type == "file" then fetch_file pkgs spec
else if spec.type == "tarball" then fetch_tarball pkgs spec
else if spec.type == "git" then fetch_git spec
else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec
else if spec.type == "builtin-url" then fetch_builtin-url spec
else
abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
# Ports of functions for older nix versions
# a Nix version of mapAttrs if the built-in doesn't exist
mapAttrs = builtins.mapAttrs or (
f: set: with builtins;
listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
);
# fetchTarball version that is compatible between all the versions of Nix
builtins_fetchTarball = { url, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchTarball;
in
if lessThan nixVersion "1.12" then
fetchTarball { inherit url; }
else
fetchTarball attrs;
# fetchurl version that is compatible between all the versions of Nix
builtins_fetchurl = { url, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchurl;
in
if lessThan nixVersion "1.12" then
fetchurl { inherit url; }
else
fetchurl attrs;
# Create the final "sources" from the config
mkSources = config:
mapAttrs (
name: spec:
if builtins.hasAttr "outPath" spec
then abort
"The values in sources.json should not have an 'outPath' attribute"
else
spec // { outPath = fetch config.pkgs name spec; }
) config.sources;
# The "config" used by the fetchers
mkConfig =
{ sourcesFile ? ./sources.json
, sources ? builtins.fromJSON (builtins.readFile sourcesFile)
, pkgs ? mkPkgs sources
}: rec {
# The sources, i.e. the attribute set of spec name to spec
inherit sources;
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
inherit pkgs;
};
in
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

View file

@ -1,6 +1,74 @@
{ pkgs ? import <nixpkgs> {} }: { nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
let let
hsPkgs = import ./default.nix;
inherit (nixpkgs) pkgs;
affection = with haskellPackages; callPackage(
{ mkDerivation, base, bytestring, clock, containers, glib, linear
, monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text
, uuid, vector
}:
mkDerivation {
pname = "affection";
version = "0.0.0.10";
src = ../affection;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
base bytestring clock containers glib linear monad-loops
monad-parallel mtl OpenGL sdl2 stm text uuid vector
];
homepage = "https://github.com/nek0/affection#readme";
description = "A simple Game Engine using SDL";
license = stdenv.lib.licenses.lgpl3;
doHaddock = false;
}) {};
#GLUtil = with haskellPackages; callPackage(
# { mkDerivation, array, base, bytestring, containers, directory
# , filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv
# , transformers, vector
# }:
# mkDerivation {
# pname = "GLUtil";
# version = "0.10.3";
# sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27";
# libraryHaskellDepends = [
# array base bytestring containers directory filepath hpp JuicyPixels
# linear OpenGL OpenGLRaw transformers vector
# ];
# libraryToolDepends = [ hpp ];
# description = "Miscellaneous OpenGL utilities";
# license = stdenv.lib.licenses.bsd3;
# }) {};
f = { mkDerivation, base, bytestring, containers
, JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw
, random, sdl2, stdenv, stm
}:
mkDerivation {
pname = "canvas";
version = "0.0.0.0";
src = ./.;
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
affection base bytestring containers JuicyPixels
JuicyPixels-extra linear OpenGL OpenGLRaw random sdl2 stm
];
description = "A test implementation for drawing images with SDL2 and OpenGL";
license = stdenv.lib.licenses.bsd3;
};
haskellPackages = if compiler == "default"
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler};
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
drv = variant (haskellPackages.callPackage f {});
in in
hsPkgs.canvas.components.all
if pkgs.lib.inNixShell then drv.env else drv