├── .gitignore ├── README.md ├── Setup.hs ├── haskell-doom.cabal └── src ├── Data └── Var.hs ├── Enemy.hs ├── Flat.hs ├── Game.hs ├── Graphics ├── Binding.hs ├── GLUtils.hs ├── Program.hs ├── Shader.hs ├── Shader │ ├── Internal.hs │ ├── Language.hs │ └── Types.hs └── TupleList.hs ├── Level └── Sector.hs ├── Main.hs ├── Render.hs ├── Sky.hs ├── Sprite.hs ├── SpriteMap.hs ├── TextureLoader.hs ├── Triangulation.hs ├── Types.hs ├── UI.hs └── Window.hs /.gitignore: -------------------------------------------------------------------------------- 1 | haskell-doom/stack.yaml 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | DOOM 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /haskell-doom.cabal: -------------------------------------------------------------------------------- 1 | -- Initial haskell-doom.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: haskell-doom 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | -- license: 9 | license-file: LICENSE 10 | author: ICHack 11 | maintainer: levex@linux.com 12 | -- copyright: 13 | category: Game 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | executable haskell-doom 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.8 && <4.9, GLFW-b >=1.4 && <1.5, delaunay, AC-Vector, OpenGLRaw >=3.0.0, linear, waddle, containers, transformers, mtl, case-insensitive, array, bytestring, free 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /src/Data/Var.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | module Data.Var where 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Reader 7 | import Data.IORef 8 | import Foreign 9 | 10 | -- Getter 11 | class Monad m => HasGetter m g a | g -> a where 12 | get :: g -> m a 13 | 14 | instance (MonadIO m, MonadReader e m, HasGetter m g a) => HasGetter m (e -> g) a where 15 | get a = do 16 | e <- asks a 17 | get e 18 | 19 | instance MonadIO m => HasGetter m (IORef a) a where 20 | get = liftIO . readIORef 21 | 22 | instance (MonadIO m, Storable a) => HasGetter m (Ptr a) a where 23 | get = liftIO . peek 24 | 25 | -- Setter 26 | class Monad m => HasSetter m s a | s -> a where 27 | ($=) :: s -> a -> m () 28 | put :: s -> a -> m () 29 | put = ($=!) 30 | ($=!) :: s -> a -> m () 31 | s $=! a = a `seq` (s $= a) 32 | 33 | instance (MonadIO m, MonadReader e m, HasSetter m g a) => HasSetter m (e -> g) a where 34 | s $= a 35 | = asks s >>= ($=! a) 36 | 37 | instance MonadIO m => HasSetter m (IORef a) a where 38 | ($=) = (.) liftIO . writeIORef 39 | 40 | instance (MonadIO m, Storable a) => HasSetter m (Ptr a) a where 41 | ($=) = (.) liftIO . poke 42 | 43 | -- Combinators 44 | -- Modify 45 | ($~) :: (HasGetter m t a, HasSetter m t a) => t -> (a -> a) -> m () 46 | ($~) a f = do 47 | e <- get a 48 | a $=! f e 49 | 50 | -- Add 51 | (+=) :: (Num a, HasGetter m t a, HasSetter m t a) => t -> a -> m () 52 | a += w = a $~ (+ w) 53 | 54 | -- Subtract 55 | (-=) :: (Num a, HasGetter m t a, HasSetter m t a) => t -> a -> m () 56 | a -= w = a $~ subtract w 57 | 58 | -- Multiply 59 | (*=) :: (Num a, HasGetter m t a, HasSetter m t a) => t -> a -> m () 60 | a *= w = a $~ (* w) 61 | -------------------------------------------------------------------------------- /src/Enemy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | module Enemy where 4 | 5 | import Types 6 | import Linear.V3 7 | import Linear.Metric 8 | import Graphics.GL.Core33 9 | import qualified Game.Waddle.Types as WAD 10 | import Debug.Trace 11 | 12 | data Enemy = Enemy { 13 | enemyPos :: Pos 14 | , enemyType :: WAD.ThingType -- Invariant: classifyThingType enemyType = Enemy _ 15 | , enemyTarget :: Maybe Thing 16 | , enemyRotate :: Rotation 17 | , enemyCurHealth :: Int 18 | } deriving (Eq, Show) 19 | 20 | --deriving instance Show WAD.ThingType 21 | deriving instance Eq WAD.ThingType 22 | 23 | mkEnemy :: WAD.Thing -> Enemy 24 | mkEnemy WAD.Thing{..} = 25 | Enemy (V3 (fromIntegral thingX) 0 (fromIntegral thingY)) 26 | thingType 27 | Nothing Forwards (enemyHealth thingType) 28 | 29 | enemyHealth :: WAD.ThingType -> Int 30 | enemyHealth = const 10 31 | 32 | fieldOfView = 180 33 | 34 | data Thing = Thing deriving (Eq, Show) 35 | 36 | thingPos :: Thing -> Pos 37 | thingPos t = V3 0 0 0 38 | 39 | data Rotation = Forwards | Backwards deriving (Eq, Show) 40 | 41 | newtype ViewDirection = ViewDirection (V3 GLfloat) 42 | 43 | viewDirection :: Rotation -> ViewDirection 44 | viewDirection Forwards = ViewDirection (V3 1 0 0) 45 | viewDirection Backwards = ViewDirection (V3 0 0 1) 46 | 47 | 48 | inFieldOfView :: Int -> ViewDirection -> Pos -> Pos -> Bool 49 | inFieldOfView fov (ViewDirection vd) myPos targetPos = 50 | let angle = 51 | acos (vd `dot` (targetPos - myPos)) 52 | / (norm vd * norm (targetPos - myPos)) 53 | in (fromIntegral fov / 2) >= angle 54 | 55 | 56 | 57 | -- | Set the target to the Thing if facing it 58 | acquireTarget :: Thing -> Enemy -> Enemy 59 | acquireTarget t e@Enemy{..} = 60 | if inFieldOfView fieldOfView (viewDirection enemyRotate) (thingPos t) enemyPos 61 | then e { enemyTarget = Just t } 62 | else e 63 | 64 | 65 | -- | Move towards target position if acquired a target or otherwise 66 | -- randomly? Also deals with orientation 67 | moveEnemy :: Enemy -> Enemy 68 | moveEnemy e@Enemy{..} = e { enemyPos = maybe enemyPos thingPos enemyTarget } 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /src/Flat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Flat ( 3 | loadFlat, 4 | flatWidth, 5 | flatHeight 6 | ) where 7 | 8 | import qualified Game.Waddle as WAD 9 | import qualified Data.ByteString as BS 10 | import qualified Data.Map as M 11 | import Data.CaseInsensitive 12 | import Data.Maybe 13 | import Control.Monad.Reader 14 | import Data.Word 15 | import Graphics.GL.Functions 16 | import Graphics.GL.Core33 17 | import TextureLoader 18 | import Game 19 | 20 | (flatWidth, flatHeight) = (64, 64) 21 | 22 | loadFlatData :: WAD.Wad -> WAD.LumpName -> [Word8] 23 | -- special, transparent flat 24 | loadFlatData wad "F_SKY1" 25 | = replicate 4096 0xFF 26 | loadFlatData wad name 27 | = BS.unpack $ WAD.flatData flat 28 | where 29 | flat = fromMaybe (error "invalid flat") $ 30 | M.lookup (mk name) (WAD.wadFlats wad) 31 | 32 | loadFlat :: WAD.LumpName -> Game [GLfloat] 33 | loadFlat name = do 34 | palette' <- asks palette 35 | wad' <- asks wad 36 | return $ unpackTuples 37 | (textureDataToColor palette' 38 | (loadFlatData wad' name)) 39 | -------------------------------------------------------------------------------- /src/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | module Game where 6 | import Control.Monad.IO.Class 7 | import Control.Monad.Reader 8 | -- ugly 9 | import Data.Word 10 | import Level.Sector 11 | import Graphics.Program 12 | import Graphics.GL.Core33 13 | import Render 14 | import Data.IORef 15 | import Enemy 16 | import Types 17 | import Data.Var 18 | 19 | newtype GameMonad e a = GameMonad { unGame :: ReaderT e IO a } 20 | deriving (Functor, Applicative, Monad, MonadIO, MonadReader e) 21 | 22 | data GameState u i = GameState { 23 | prog :: Program u i 24 | , sideDefs :: Int 25 | , levelRd :: [RenderData] 26 | , floorRd :: RenderData 27 | , sprites :: [Sprite] 28 | , currentSector :: IORef Sector 29 | , rot :: IORef GLfloat 30 | , player :: IORef Pos 31 | , enemies :: IORef [Enemy] 32 | , palette :: ColorPalette 33 | , sky :: RenderData 34 | , pWeapon :: RenderData 35 | , ticks :: IORef Int 36 | , lastShot :: IORef Int 37 | } 38 | 39 | data Sprite = Sprite { 40 | spriteName :: String, -- sprite name in WAD 41 | spriteActive :: IORef Bool, -- whether we can start moving 42 | spriteAnimFrame :: IORef Int, -- current animation frame 43 | spriteRenderData :: RenderData, 44 | spritePos :: Pos 45 | } 46 | 47 | type ColorPalette = [[(Word8, Word8, Word8)]] 48 | 49 | type Game a = forall u i. GameMonad (GameState u i) a 50 | 51 | runGame :: GameMonad e a -> e -> IO a 52 | runGame = runReaderT . unGame 53 | 54 | gameLogic :: Game () 55 | gameLogic = do 56 | updateSector 57 | enemiesLogic 58 | 59 | 60 | enemiesLogic :: Game () 61 | enemiesLogic = 62 | enemies $~ map (acquireTarget Thing . moveEnemy) 63 | 64 | 65 | updateSector :: Game () 66 | updateSector = return () 67 | -------------------------------------------------------------------------------- /src/Graphics/Binding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | --{-# LANGUAGE PolyKinds #-} 10 | 11 | module Graphics.Binding where 12 | import Control.Monad 13 | import Control.Monad.IO.Class 14 | import Data.Proxy 15 | import Data.Var 16 | import Foreign 17 | import Foreign.C.String 18 | import Graphics.GL 19 | import Graphics.Program 20 | import Graphics.Shader 21 | import Graphics.Shader.Types 22 | import Linear 23 | import Graphics.TupleList 24 | 25 | data Bindable (k :: [Arg]) a = Bindable [a] 26 | 27 | type family ArgMap (xs :: [Arg]) :: [*] where 28 | ArgMap '[] = '[] 29 | ArgMap (x ': xs) = (ArgToLinear x ': ArgMap xs) 30 | 31 | bindVertexData :: (x ~ FromList (ArgMap i), ToList x GLfloat, TypeInfo i, MonadIO m) => Program i u -> [x] -> m () 32 | bindVertexData p xs = bindVertexData' p b 33 | where b = Bindable $ concatMap toList' xs :: Bindable i GLfloat 34 | 35 | bindVertexData' :: forall a i u m. 36 | (Storable a, GLTypeable a, TypeInfo i, MonadIO m) => 37 | Program i u -> Bindable i a -> m () 38 | bindVertexData' (Program progId) (Bindable bdata) = liftIO $ do 39 | withArrayLen bdata $ \len vertices -> 40 | glBufferData GL_ARRAY_BUFFER 41 | (fromIntegral $ len * dataSize) 42 | (vertices :: Ptr a) 43 | GL_STATIC_DRAW 44 | foldM_ (\offset (name, size) -> do 45 | attrib <- fromIntegral <$> 46 | withCString name (glGetAttribLocation progId) 47 | glEnableVertexAttribArray attrib 48 | glVertexAttribPointer attrib 49 | size 50 | (glType proxy) 51 | (fromBool False) 52 | (fromIntegral $ totalSize * dataSize) 53 | offset 54 | return (offset `plusPtr` fromIntegral (size * fromIntegral dataSize)) 55 | ) nullPtr (map (fmap (fromIntegral . glslTypeSize)) extracted) 56 | where extracted = extract (Proxy :: Proxy i) 57 | totalSize = fromIntegral $ sum . map (glslTypeSize . snd) $ extracted 58 | dataSize = sizeOf proxy 59 | proxy = undefined :: a 60 | 61 | -- Uniform binding 62 | data Uniform u (v :: Arg) a = forall i proxy. Uniform (Program u i) (proxy v) 63 | 64 | instance (MonadIO m, HasBinder a, TypeInfo '[v], Compatible v a) => HasSetter m (Uniform u v a) a where 65 | (Uniform (Program progId) _) $= uniData = liftIO $ do 66 | let (name, _) = head $ extract (Proxy :: Proxy '[v]) 67 | uniId <- withCString name $ glGetUniformLocation progId 68 | bindUniform uniData (fromIntegral uniId) 1 69 | 70 | class Storable v => HasBinder v where 71 | bindFunc :: v -> GLint -> GLsizei -> Ptr a -> IO () 72 | bindUniform :: MonadIO m => v -> GLint -> GLsizei -> m () 73 | bindUniform val loc count = liftIO $ 74 | with val $ \trans -> bindFunc val loc count trans 75 | 76 | instance HasBinder (M44 GLfloat) where 77 | bindFunc _ = matrixBinder glUniformMatrix4fv 78 | 79 | instance HasBinder (M33 GLfloat) where 80 | bindFunc _ = matrixBinder glUniformMatrix3fv 81 | 82 | instance HasBinder (M23 GLfloat) where 83 | bindFunc _ = matrixBinder glUniformMatrix2x3fv 84 | -- TODO: add other matrices 85 | 86 | instance HasBinder (V4 GLfloat) where 87 | bindFunc _ = vectorBinder glUniform4fv 88 | 89 | instance HasBinder (V3 GLfloat) where 90 | bindFunc _ = vectorBinder glUniform3fv 91 | 92 | instance HasBinder (V2 GLfloat) where 93 | bindFunc _ = vectorBinder glUniform2fv 94 | 95 | instance HasBinder (V1 GLfloat) where 96 | bindFunc _ = vectorBinder glUniform1fv 97 | -- TODO: add other vectors (GLint) 98 | 99 | matrixBinder :: MonadIO m => 100 | (GLint -> GLsizei -> GLboolean -> Ptr a -> IO ()) -> 101 | GLint -> GLsizei -> Ptr b -> m () 102 | matrixBinder f loc count val 103 | = liftIO $ f loc count (fromBool True) (castPtr val) 104 | 105 | vectorBinder :: MonadIO m => 106 | (GLint -> GLsizei -> Ptr a -> IO ()) -> 107 | GLint -> GLsizei -> Ptr b -> m () 108 | vectorBinder f loc count val 109 | = liftIO $ f loc count (castPtr val) 110 | 111 | -- Fragment shader 112 | data FragmentShaderField 113 | = FragDiffuseColor -- 0 114 | | FragMaterialID -- 1 115 | | FragSpecularColor -- 2 116 | | FragPosition -- 3 117 | | FragNormal -- 4 118 | deriving Enum 119 | 120 | data FragShaderLocation = FragShaderLocation ProgId String 121 | 122 | instance MonadIO m => HasSetter m FragShaderLocation FragmentShaderField where 123 | (FragShaderLocation progId name) $= loc 124 | = liftIO . withCString name $ 125 | glBindFragDataLocation progId (fromIntegral $ fromEnum loc) 126 | 127 | -------------------------------------------------------------------------------- /src/Graphics/GLUtils.hs: -------------------------------------------------------------------------------- 1 | module Graphics.GLUtils where 2 | import Data.Var 3 | import Graphics.GL 4 | import Foreign.C.String 5 | import Foreign 6 | import Control.Monad 7 | 8 | -- Misc aux. functions 9 | offsetPtr :: Storable a => Int -> a -> Ptr GLvoid 10 | offsetPtr x s = plusPtr nullPtr (fromIntegral $ x * sizeOf s) 11 | 12 | withNewPtr :: Storable a => (Ptr a -> IO b) -> IO a 13 | withNewPtr f = alloca (\p -> f p >> get p) 14 | 15 | shaderFromString :: GLenum -> String -> IO GLuint 16 | shaderFromString shaderTypeFlag code = do 17 | shader <- glCreateShader shaderTypeFlag 18 | withCString code $ \codePtr -> 19 | with codePtr $ \codePtrPtr -> 20 | glShaderSource shader 1 codePtrPtr nullPtr 21 | glCompileShader shader 22 | status <- toBool <$> withNewPtr (glGetShaderiv shader GL_COMPILE_STATUS) 23 | unless status $ 24 | alloca $ \err -> do 25 | glGetShaderInfoLog shader 512 nullPtr err 26 | err' <- peekCString err 27 | error err' 28 | return shader 29 | 30 | 31 | loadShader :: GLenum -> FilePath -> IO GLuint 32 | loadShader shaderTypeFlag filePath = do 33 | code <- readFile filePath 34 | shaderFromString shaderTypeFlag code 35 | 36 | -------------------------------------------------------------------------------- /src/Graphics/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE DataKinds #-} 3 | module Graphics.Program where 4 | 5 | import Graphics.Shader 6 | import Graphics.Shader.Types 7 | import GHC.TypeLits 8 | import Graphics.GL 9 | import Graphics.GLUtils 10 | 11 | type ProgId = GLuint 12 | 13 | data Program (inputs :: [Arg]) 14 | (uniforms :: [Arg]) 15 | = Program ProgId 16 | 17 | mkProgram :: ( KnownNat ver 18 | , TypeInfo i 19 | , TypeInfo o 20 | , TypeInfo u 21 | , TypeInfo o' 22 | , TypeInfo u' ) => 23 | Shader ver i o u a -> Shader ver o o' u' a' -> IO (Program i (Union u u')) 24 | mkProgram vert frag = do 25 | progId <- glCreateProgram 26 | vertS <- shaderFromString GL_VERTEX_SHADER (showShader vert) 27 | fragS <- shaderFromString GL_FRAGMENT_SHADER (showShader frag) 28 | glAttachShader progId vertS 29 | glAttachShader progId fragS 30 | 31 | glLinkProgram progId 32 | glUseProgram progId 33 | glDeleteShader vertS 34 | glDeleteShader fragS 35 | return $ Program progId 36 | -------------------------------------------------------------------------------- /src/Graphics/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | module Graphics.Shader 5 | ( I.Shader(..) 6 | , I.showShader 7 | , T.GLSLType 8 | , T.GLTypeable(..) 9 | , T.TypeInfo(..) 10 | , I.Union 11 | , textureFrag 12 | , wallVert 13 | , spriteVert 14 | , floorFrag 15 | , floorVert 16 | , staticVert 17 | , glslTypeSize 18 | , Pos3 19 | , VertexPos 20 | , model 21 | , view 22 | , proj 23 | , Tex2) where 24 | import Graphics.Shader.Internal as I 25 | import Graphics.Shader.Types as T 26 | 27 | -- TODO: swizzling 28 | 29 | type Pos3 = 'Arg "position" 'Vec3 30 | pos3 :: SVar Pos3 31 | pos3 = SVar 32 | 33 | type Tex2 = 'Arg "texcoord" 'Vec2 34 | tex2 :: SVar Tex2 35 | tex2 = SVar 36 | 37 | type Texcoord = 'Arg "Texcoord" 'Vec2 38 | texcoord :: SVar Texcoord 39 | texcoord = SVar 40 | 41 | type GlPos = 'Arg "gl_Position" 'Vec4 42 | glPos :: SVar GlPos 43 | glPos = SVar 44 | 45 | type Model = 'Arg "model" 'Mat4 46 | model :: SVar Model 47 | model = SVar 48 | 49 | type View = 'Arg "view" 'Mat4 50 | view :: SVar View 51 | view = SVar 52 | 53 | type Proj = 'Arg "proj" 'Mat4 54 | proj :: SVar Proj 55 | proj = SVar 56 | 57 | type Outcolor = 'Arg "outColor" 'Vec4 58 | outcolor :: SVar Outcolor 59 | outcolor = SVar 60 | 61 | type TexSampler = 'Arg "tex" 'Sampler2D 62 | texSampler :: SVar TexSampler 63 | texSampler = SVar 64 | 65 | type VertexPos = 'Arg "vertexPos" 'Float 66 | vertexPos :: SVar VertexPos 67 | vertexPos = SVar 68 | 69 | wallVert :: Shader 150 '[Pos3, Tex2] '[Texcoord] '[Model, View, Proj] () 70 | wallVert = do 71 | out texcoord =: inp tex2 72 | var glPos =: (uni proj *: uni view *: uni model *: (inp pos3 &: float 1)) 73 | 74 | textureFrag :: Shader 150 '[Texcoord] '[Outcolor] '[TexSampler] () 75 | textureFrag 76 | = out outcolor =: texture (uni texSampler) (inp texcoord) 77 | 78 | spriteVert :: Shader 150 '[Pos3, VertexPos, Tex2] '[Texcoord] '[Model, View, Proj] () 79 | spriteVert = do 80 | out texcoord =: inp tex2 81 | var glPos =: (uni proj *: uni view *: uni model *: (inp pos3 &: float 1)) 82 | var glPos `at` _0 +=: var vertexPos 83 | 84 | staticVert :: Shader 150 '[Pos3, Tex2] '[Texcoord] '[] () 85 | staticVert = do 86 | out texcoord =: inp tex2 87 | var glPos =: inp pos3 &: float 1.0 88 | 89 | floorVert :: Shader 150 '[Pos3] '[] '[Model, View, Proj] () 90 | floorVert 91 | = var glPos =: uni proj *: uni view *: uni model *: (inp pos3 &: float 1) 92 | 93 | floorFrag :: Shader 150 '[] '[Outcolor] '[] () 94 | floorFrag 95 | = out outcolor =: float 0.2 &: float 0.2 &: float 0.2 &: float 1.0 96 | -------------------------------------------------------------------------------- /src/Graphics/Shader/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE Rank2Types #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | module Graphics.Shader.Internal where 14 | import Graphics.Shader.Language 15 | import Graphics.Shader.Types 16 | import GHC.TypeLits 17 | import Data.Proxy 18 | import Control.Monad.Free 19 | import Control.Monad.Writer 20 | import Control.Applicative 21 | 22 | data ExpFunctor a 23 | = Assignment Exp a 24 | | Definition Exp a 25 | deriving Functor 26 | 27 | newtype Shader (ver :: Nat) (i :: [Arg]) (o :: [Arg]) (u :: [Arg]) a 28 | = Shader (Free ExpFunctor a) 29 | deriving (Functor, Applicative, Monad) 30 | 31 | class (Functor f) => Print f where 32 | execPrint :: f (Writer [String] a) -> Writer [String] a 33 | 34 | instance Print ExpFunctor where 35 | execPrint (Assignment expr cont) 36 | = tell [show expr ++ ";"] >> cont 37 | execPrint (Definition expr cont) 38 | = tell [show expr ++ ";"] >> cont 39 | 40 | -- Fold the free monad 41 | foldShader :: (a -> b) -> (ExpFunctor b -> b) -> Shader v i o u a -> b 42 | foldShader p i (Shader s) 43 | = foldFree' p i s 44 | where foldFree' pure' _ (Pure p') 45 | = pure' p' 46 | foldFree' pure' impure (Free i') 47 | = impure $ fmap (foldFree' pure' impure) i' 48 | 49 | -- Show shader by extracting the type information and folding the free monad 50 | showShader :: forall v i o u a. 51 | (KnownNat v, TypeInfo i, TypeInfo o, TypeInfo u) => 52 | Shader v i o u a -> String 53 | showShader shader 54 | = unlines (version : ins ++ unis ++ outs) 55 | ++ "\n" 56 | ++ "void main() {\n" 57 | ++ unlines (map ("\t" ++) body) 58 | ++ "}" 59 | where version = "#version " ++ show (natVal (Proxy :: Proxy v)) 60 | ins = extr "in" (Proxy :: Proxy i) 61 | outs = extr "out" (Proxy :: Proxy o) 62 | unis = extr "uniform" (Proxy :: Proxy u) 63 | body = snd . runWriter . foldShader pure execPrint $ shader 64 | 65 | extr what from 66 | = map (uncurry $ showT what) (extract from) 67 | showT w name typ 68 | = w ++ " " ++ show typ ++ " " ++ name ++ ";" 69 | 70 | type LiftVar n i o u t = 71 | forall ver proxy. 72 | (KnownSymbol n, Expression (FromArg t)) => 73 | proxy ('Arg n t) -> Shader ver i o u (FromArg t) 74 | 75 | inp :: forall n i o u t. Elem ('Arg n t) i => LiftVar n i o u t 76 | inp _ = pure $ fromExpression (Var name) 77 | where name = symbolVal (Proxy :: Proxy n) 78 | 79 | out :: forall n i o u t. Elem ('Arg n t) o => LiftVar n i o u t 80 | out _ = pure $ fromExpression (Var name) 81 | where name = symbolVal (Proxy :: Proxy n) 82 | 83 | uni :: forall n i o u t. Elem ('Arg n t) u => LiftVar n i o u t 84 | uni _ = pure $ fromExpression (Var name) 85 | where name = symbolVal (Proxy :: Proxy n) 86 | 87 | var :: forall n i o u t. LiftVar n i o u t 88 | var _ = pure $ fromExpression (Var name) 89 | where name = symbolVal (Proxy :: Proxy n) 90 | 91 | -- TODO: automatically define variables as they are used 92 | -- or rely on the type checker to catch undefined variable usage 93 | def :: forall n i o u t. ShowType (FromArg t) => LiftVar n i o u t 94 | def _ = imp (Definition (Define e) e) 95 | where e = fromExpression $ Var $ symbolVal (Proxy :: Proxy n) :: FromArg t 96 | 97 | float :: Applicative f => Double -> f Scalar 98 | float = pure . Scalar . EScalar 99 | 100 | -- Bilinear maps 101 | class (Expression a, Expression b, Expression c) => Bilinear a b c | a b -> c where 102 | infixl 8 *:: 103 | (*::) :: a -> b -> c 104 | a *:: b = fromExpression (Wrap a * Wrap b) 105 | infixl 8 *: 106 | (*:) :: Applicative f => f a -> f b -> f c 107 | (*:) = liftA2 (*::) 108 | 109 | instance KnownNat n => Bilinear (Vec n) (Vec n) (Vec n) 110 | 111 | instance (KnownNat a, KnownNat b, KnownNat c) => 112 | Bilinear (Mat a b) (Mat b c) (Mat a c) 113 | 114 | instance (KnownNat a, KnownNat b) => Bilinear (Mat a b) (Vec b) (Vec b) 115 | 116 | instance Expression a => Bilinear a Scalar a 117 | 118 | class Indexable a where 119 | type TypeAtIndex a 120 | indexAt :: a -> Int -> TypeAtIndex a 121 | 122 | instance (KnownNat a, KnownNat b) => Indexable (Mat a b) where 123 | type TypeAtIndex (Mat a b) = Vec b 124 | indexAt mat i = Vec (EIndex mat i) 125 | 126 | instance KnownNat d => Indexable (Vec d) where 127 | type TypeAtIndex (Vec d) = Scalar 128 | indexAt = (.) Scalar . EIndex 129 | 130 | _0 :: (Indexable a, 1 <= Size a) => a -> TypeAtIndex a 131 | _0 a = indexAt a 0 132 | 133 | _1 :: (Indexable a, 2 <= Size a) => a -> TypeAtIndex a 134 | _1 a = indexAt a 1 135 | 136 | _2 :: (Indexable a, 3 <= Size a) => a -> TypeAtIndex a 137 | _2 a = indexAt a 2 138 | 139 | _3 :: (Indexable a, 4 <= Size a) => a -> TypeAtIndex a 140 | _3 a = indexAt a 3 141 | 142 | _4 :: (Indexable a, 5 <= Size a) => a -> TypeAtIndex a 143 | _4 a = indexAt a 4 144 | 145 | at :: Functor f => f a -> (a -> b) -> f b 146 | at = flip (<$>) 147 | 148 | class Expression a => Group a where 149 | infixl 8 +:: 150 | infixl 8 +: 151 | infixl 8 -:: 152 | infixl 8 -: 153 | -- add 154 | (+::) :: a -> a -> a 155 | a +:: b = fromExpression (Wrap a + Wrap b) 156 | (+:) :: Applicative f => f a -> f a -> f a 157 | (+:) = liftA2 (+::) 158 | -- subtract 159 | (-::) :: a -> a -> a 160 | a -:: b = fromExpression (Wrap a - Wrap b) 161 | (-:) :: Applicative f => f a -> f a -> f a 162 | (-:) = liftA2 (-::) 163 | 164 | instance Expression a => Group a 165 | 166 | -- Things that can be turned into vectors 167 | class (KnownNat (Size a)) => Vectorable a where 168 | fromVectorable :: (Size a ~ n) => a -> Vec n 169 | 170 | instance Vectorable Scalar where 171 | fromVectorable (Scalar p) = Vec p 172 | 173 | instance KnownNat n => Vectorable (Vec n) where 174 | fromVectorable = id 175 | 176 | type family Size v where 177 | Size (Mat a b) = a 178 | Size (Vec n) = n 179 | Size Scalar = 1 180 | 181 | class Combinable a b where 182 | type Combined a b 183 | (&::) :: a -> b -> Combined a b 184 | (&:) :: Applicative f => f a -> f b -> f (Combined a b) 185 | (&:) = liftA2 (&::) 186 | 187 | instance (Vectorable a, Vectorable b) => Combinable a b where 188 | type Combined a b = Vec (Size a + Size b) 189 | v1 &:: v2 = Vec (Combine (fromVectorable v1) (fromVectorable v2)) 190 | 191 | class Assignable a where 192 | infixl 2 =:: 193 | (=::) :: a -> a -> Shader v i o u () 194 | infixl 2 =: 195 | (=:) :: Shader v i o u a -> Shader v i o u a -> Shader v i o u () 196 | (=:) a b = join $ liftA2 (=::) a b 197 | 198 | infixl 2 -=: 199 | a -=: b = a =: a -: b 200 | 201 | infixl 2 +=: 202 | a +=: b = a =: a +: b 203 | 204 | instance Expression a => Assignable a where 205 | v =:: val = imp $ Assignment (Assign (toExpression v) val) () 206 | 207 | texture :: (KnownNat n, Applicative f) => f (Sampler m) -> f (Vec n) -> f (Vec 4) 208 | texture = liftA2 func 209 | where func (Sampler s) v = Vec (FuncApp "texture" [s, Wrap v]) 210 | 211 | imp :: ExpFunctor a -> Shader v i o u a 212 | imp c = Shader (Free (fmap Pure c)) 213 | 214 | -- Constraint is only satisifed when x is an element of the type-level list xs 215 | class Elem x xs 216 | 217 | instance Elem x xs => Elem x (y ': xs) 218 | instance {-# OVERLAPPING #-} Elem x (x ': xs) 219 | 220 | -- Append two lists together, maybe should nub? 221 | type family (Union (l1 :: [k]) (l2 :: [k])) where 222 | Union l '[] = l 223 | Union l1 (a ': l2) = Union (a ': l1) l2 224 | -------------------------------------------------------------------------------- /src/Graphics/Shader/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | module Graphics.Shader.Language where 9 | import Graphics.Shader.Types 10 | import Data.List (intercalate) 11 | import GHC.TypeLits 12 | import Data.Proxy 13 | 14 | data Exp 15 | = Var String 16 | | EScalar Double 17 | | forall t. Expression t => EIndex t Int 18 | | forall t1 t2. (Expression t1, Expression t2) => Combine t1 t2 19 | | forall t. (Expression t) => Wrap t 20 | | FuncApp String [Exp] 21 | | Mul Exp Exp 22 | | Add Exp Exp 23 | | Negate Exp 24 | | Abs Exp 25 | | Signum Exp 26 | | forall t. (Expression t) => Assign Exp t 27 | | forall t. (Expression t, ShowType t) => Define t 28 | 29 | instance Num Exp where 30 | (*) = Mul 31 | (+) = Add 32 | abs = Abs 33 | signum = Signum 34 | fromInteger = EScalar . fromInteger 35 | negate (Negate n) = n 36 | negate n = Negate n 37 | 38 | instance Show Exp where 39 | show (Var name) 40 | = name 41 | show (EIndex e i) 42 | = show e ++ "[" ++ show i ++ "]" 43 | show (Combine e1 e2) 44 | = e1s ++ ", " ++ e2s 45 | where e1s = case toExpression e1 of 46 | Combine e1' e1'' 47 | -> show e1' ++ ", " ++ show e1'' 48 | _ -> show e1 49 | e2s = case toExpression e2 of 50 | Combine e2' e2'' 51 | -> show e2' ++ ", " ++ show e2'' 52 | _ -> show e2 53 | show (FuncApp funcname es) 54 | = funcname ++ "(" ++ intercalate ", " (map show es) ++ ")" 55 | show (Wrap e) 56 | = show e 57 | show (Mul e1 e2) 58 | = show e1 ++ " * " ++ show e2 59 | show (Add e1 e2) 60 | = show e1 ++ " + " ++ show e2 61 | show (Assign e1 e2) 62 | = show e1 ++ " = " ++ show e2 63 | show (Define e) 64 | = showType e ++ " " ++ show e 65 | show (EScalar s) 66 | = show s 67 | show (Abs e) 68 | = "abs(" ++ show e ++ ")" 69 | show (Signum e) 70 | = "signum(" ++ show e ++ ")" 71 | show (Negate s) 72 | = "-" ++ show s 73 | 74 | class Show a => Expression a where 75 | fromExpression :: Exp -> a 76 | toExpression :: a -> Exp 77 | 78 | class ShowType a where 79 | showType :: a -> String 80 | 81 | data Scalar 82 | = Scalar Exp 83 | 84 | instance ShowType Scalar where 85 | showType _ 86 | = "float" 87 | 88 | instance Show Scalar where 89 | show (Scalar e) 90 | = show e 91 | 92 | data Vec (dim :: Nat) 93 | = Vec Exp 94 | 95 | instance (KnownNat n) => ShowType (Vec n) where 96 | showType (Vec _) 97 | = "vec" ++ dim 98 | where dim = show $ natVal (Proxy :: Proxy n) 99 | 100 | instance KnownNat n => Show (Vec n) where 101 | show vec@(Vec expr) 102 | = case expr of 103 | expr'@Combine{} -> w expr' 104 | _ -> show expr 105 | where dim = natVal (Proxy :: Proxy n) 106 | w e = case dim of 107 | 1 -> show e 108 | _ -> showType vec ++ "(" ++ show e ++ ")" 109 | 110 | data Mat (rows :: Nat) (cols :: Nat) 111 | = Mat Exp 112 | 113 | instance (KnownNat r, KnownNat c) => ShowType (Mat r c) where 114 | showType (Mat _) 115 | = "mat" ++ rdim ++ "x" ++ cdim 116 | where rdim = show $ natVal (Proxy :: Proxy r) 117 | cdim = show $ natVal (Proxy :: Proxy r) 118 | 119 | instance (KnownNat r, KnownNat c) => Show (Mat r c) where 120 | show mat@(Mat expr) 121 | = case expr of 122 | expr'@Combine{} -> w expr' 123 | _ -> show expr 124 | where w e = showType mat ++ "(" ++ show e ++ ")" 125 | 126 | data Sampler (d :: Nat) 127 | = Sampler Exp 128 | deriving Show 129 | 130 | instance Expression Scalar where 131 | fromExpression = Scalar 132 | toExpression (Scalar p) = p 133 | 134 | instance (Show (Vec d), KnownNat d) => Expression (Vec d) where 135 | fromExpression = Vec 136 | toExpression (Vec e) = e 137 | 138 | instance (Show (Mat r c), KnownNat r, KnownNat c) => Expression (Mat r c) where 139 | fromExpression = Mat 140 | toExpression (Mat e) = e 141 | 142 | instance (Show (Sampler n), KnownNat n) => Expression (Sampler n) where 143 | fromExpression = Sampler 144 | toExpression (Sampler e) = e 145 | 146 | -- ARGUMENT TYPES 147 | type family FromArg a where 148 | FromArg 'Float = Scalar 149 | FromArg 'Vec2 = Vec 2 150 | FromArg 'Vec3 = Vec 3 151 | FromArg 'Vec4 = Vec 4 152 | FromArg 'Mat1 = Mat 1 1 153 | FromArg 'Mat2 = Mat 2 2 154 | FromArg 'Mat3 = Mat 3 3 155 | FromArg 'Mat4 = Mat 4 4 156 | FromArg 'Sampler2D = Sampler 2 157 | 158 | -------------------------------------------------------------------------------- /src/Graphics/Shader/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | module Graphics.Shader.Types where 9 | import Data.Proxy 10 | import GHC.TypeLits 11 | import Graphics.GL 12 | import Data.Int 13 | import Data.Word 14 | import Linear 15 | 16 | data Arg = Arg Symbol GLSLType 17 | 18 | -- Convert between Haskell types and GL scalar primitives 19 | class GLTypeable a where 20 | glType :: a -> GLenum 21 | 22 | instance GLTypeable Int where 23 | glType _ = GL_INT 24 | 25 | instance GLTypeable Float where 26 | glType _ = GL_FLOAT 27 | 28 | instance GLTypeable Double where 29 | glType _ = GL_DOUBLE 30 | 31 | instance GLTypeable Word8 where 32 | glType _ = GL_UNSIGNED_BYTE 33 | 34 | instance GLTypeable Word16 where 35 | glType _ = GL_UNSIGNED_SHORT 36 | 37 | instance GLTypeable Word32 where 38 | glType _ = GL_UNSIGNED_INT 39 | 40 | instance GLTypeable Int8 where 41 | glType _ = GL_BYTE 42 | 43 | instance GLTypeable Int16 where 44 | glType _ = GL_SHORT 45 | 46 | -- Poly-kinded proxy for the shader variables used in the DSL 47 | data SVar (a :: k) = SVar 48 | 49 | data GLSLType 50 | = Float 51 | | Vec2 52 | | Vec3 53 | | Vec4 54 | | Mat1 55 | | Mat2 56 | | Mat3 57 | | Mat4 58 | | Sampler2D 59 | 60 | -- Compatibility with the respective types from the Linear library 61 | class Compatible a b 62 | 63 | instance (FromLinear a ~ typ) => Compatible a ('Arg name typ) 64 | instance (FromLinear a ~ typ) => Compatible ('Arg name typ) a 65 | 66 | type family FromLinear a where 67 | FromLinear (M22 a) = 'Mat2 68 | FromLinear (M33 a) = 'Mat3 69 | FromLinear (M44 a) = 'Mat4 70 | FromLinear (V2 a) = 'Vec2 71 | FromLinear (V3 a) = 'Vec3 72 | FromLinear (V4 a) = 'Vec4 73 | 74 | type family ArgToLinear a where 75 | ArgToLinear ('Arg s 'Mat2) = (M22 GLfloat) 76 | ArgToLinear ('Arg s 'Mat3) = (M33 GLfloat) 77 | ArgToLinear ('Arg s 'Mat4) = (M44 GLfloat) 78 | ArgToLinear ('Arg s 'Float) = (V1 GLfloat) 79 | ArgToLinear ('Arg s 'Vec2) = (V2 GLfloat) 80 | ArgToLinear ('Arg s 'Vec3) = (V3 GLfloat) 81 | ArgToLinear ('Arg s 'Vec4) = (V4 GLfloat) 82 | 83 | instance Show GLSLType where 84 | show Float = "float" 85 | show Vec2 = "vec2" 86 | show Vec3 = "vec3" 87 | show Vec4 = "vec4" 88 | show Mat1 = "mat1" 89 | show Mat2 = "mat2" 90 | show Mat3 = "mat3" 91 | show Mat4 = "mat4" 92 | show Sampler2D = "sampler2D" 93 | 94 | glslTypeSize :: GLSLType -> Int 95 | glslTypeSize Float = 1 96 | glslTypeSize Vec2 = 2 97 | glslTypeSize Vec3 = 3 98 | glslTypeSize Vec4 = 4 99 | glslTypeSize Mat1 = 1 100 | glslTypeSize Mat2 = 4 101 | glslTypeSize Mat3 = 9 102 | glslTypeSize Mat4 = 16 103 | glslTypeSize _ = undefined 104 | 105 | -- Extract type information from a list of type-level tuples. 106 | -- The shader variables are stored in this format at the type-level 107 | class TypeInfo (f :: [Arg]) where 108 | extract :: proxy f -> [(String, GLSLType)] 109 | 110 | instance TypeInfo '[] where 111 | extract _ = [] 112 | 113 | instance (KnownSymbol sym, KnownGLSLType arg, TypeInfo xs) => 114 | TypeInfo (('Arg sym arg) ': xs) where 115 | extract _ = ( symbolVal (Proxy :: Proxy sym) 116 | , argVal (Proxy :: Proxy arg) 117 | ) : extract (Proxy :: Proxy xs) 118 | 119 | -- Get back the term-level constructor from the promoted ones 120 | class KnownGLSLType v where 121 | argVal :: proxy v -> GLSLType 122 | instance KnownGLSLType 'Float where 123 | argVal _ = Float 124 | instance KnownGLSLType 'Vec2 where 125 | argVal _ = Vec2 126 | instance KnownGLSLType 'Vec3 where 127 | argVal _ = Vec3 128 | instance KnownGLSLType 'Vec4 where 129 | argVal _ = Vec4 130 | instance KnownGLSLType 'Mat1 where 131 | argVal _ = Mat1 132 | instance KnownGLSLType 'Mat2 where 133 | argVal _ = Mat2 134 | instance KnownGLSLType 'Mat3 where 135 | argVal _ = Mat3 136 | instance KnownGLSLType 'Mat4 where 137 | argVal _ = Mat4 138 | instance KnownGLSLType 'Sampler2D where 139 | argVal _ = Sampler2D 140 | -------------------------------------------------------------------------------- /src/Graphics/TupleList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | {- GENERATED -} 8 | module Graphics.TupleList where 9 | import Data.Foldable (toList) 10 | 11 | type family FromList (a :: [*]) where 12 | FromList '[a1] = a1 13 | FromList '[a1, a2] = (a1, a2) 14 | FromList '[a1, a2, a3] = (a1, a2, a3) 15 | FromList '[a1, a2, a3, a4] = (a1, a2, a3, a4) 16 | FromList '[a1, a2, a3, a4, a5] = (a1, a2, a3, a4, a5) 17 | FromList '[a1, a2, a3, a4, a5, a6] = (a1, a2, a3, a4, a5, a6) 18 | FromList '[a1, a2, a3, a4, a5, a6, a7] = (a1, a2, a3, a4, a5, a6, a7) 19 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8] = (a1, a2, a3, a4, a5, a6, a7, a8) 20 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9] = (a1, a2, a3, a4, a5, a6, a7, a8, a9) 21 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) 22 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) 23 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) 24 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) 25 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) 26 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) 27 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16) 28 | FromList '[a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17] = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17) 29 | 30 | class ToList a b where 31 | toList' :: a -> [b] 32 | 33 | instance (Foldable t1) => ToList (t1 a) a where 34 | toList' = toList 35 | instance (Foldable t1, Foldable t2) => ToList (t1 a, t2 a) a where 36 | toList' (a1, a2) = toList a1 ++ toList a2 37 | instance (Foldable t1, Foldable t2, Foldable t3) => ToList (t1 a, t2 a, t3 a) a where 38 | toList' (a1, a2, a3) = toList a1 ++ toList a2 ++ toList a3 39 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4) => ToList (t1 a, t2 a, t3 a, t4 a) a where 40 | toList' (a1, a2, a3, a4) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 41 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a) a where 42 | toList' (a1, a2, a3, a4, a5) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 43 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a) a where 44 | toList' (a1, a2, a3, a4, a5, a6) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 45 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a) a where 46 | toList' (a1, a2, a3, a4, a5, a6, a7) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 47 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a) a where 48 | toList' (a1, a2, a3, a4, a5, a6, a7, a8) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 49 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a) a where 50 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 51 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a) a where 52 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 53 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a) a where 54 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 55 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11, Foldable t12) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a, t12 a) a where 56 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 ++ toList a12 57 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11, Foldable t12, Foldable t13) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a, t12 a, t13 a) a where 58 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 ++ toList a12 ++ toList a13 59 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11, Foldable t12, Foldable t13, Foldable t14) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a, t12 a, t13 a, t14 a) a where 60 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 ++ toList a12 ++ toList a13 ++ toList a14 61 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11, Foldable t12, Foldable t13, Foldable t14, Foldable t15) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a, t12 a, t13 a, t14 a, t15 a) a where 62 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 ++ toList a12 ++ toList a13 ++ toList a14 ++ toList a15 63 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11, Foldable t12, Foldable t13, Foldable t14, Foldable t15, Foldable t16) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a, t12 a, t13 a, t14 a, t15 a, t16 a) a where 64 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 ++ toList a12 ++ toList a13 ++ toList a14 ++ toList a15 ++ toList a16 65 | instance (Foldable t1, Foldable t2, Foldable t3, Foldable t4, Foldable t5, Foldable t6, Foldable t7, Foldable t8, Foldable t9, Foldable t10, Foldable t11, Foldable t12, Foldable t13, Foldable t14, Foldable t15, Foldable t16, Foldable t17) => ToList (t1 a, t2 a, t3 a, t4 a, t5 a, t6 a, t7 a, t8 a, t9 a, t10 a, t11 a, t12 a, t13 a, t14 a, t15 a, t16 a, t17 a) a where 66 | toList' (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17) = toList a1 ++ toList a2 ++ toList a3 ++ toList a4 ++ toList a5 ++ toList a6 ++ toList a7 ++ toList a8 ++ toList a9 ++ toList a10 ++ toList a11 ++ toList a12 ++ toList a13 ++ toList a14 ++ toList a15 ++ toList a16 ++ toList a17 67 | -------------------------------------------------------------------------------- /src/Level/Sector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Level.Sector ( 4 | extractSectors 5 | , extractSubSectors 6 | , Sector(..) 7 | , Wall(..) 8 | , Subsector 9 | , textToVertexData 10 | ) where 11 | 12 | import Data.List 13 | import Graphics.GL 14 | import Linear 15 | import Render 16 | import qualified Data.Map as M 17 | import qualified Game.Waddle as WAD 18 | 19 | -- TYPES ----------------------------------------------------------------------- 20 | data Sector = Sector { 21 | --sectorFloorPoints :: [Vertex2D] 22 | sectorWalls :: [Wall] 23 | , sectorCeiling :: GLfloat 24 | , sectorFloor :: GLfloat 25 | } deriving Show 26 | 27 | data Wall = Wall { 28 | wallStart :: Vertex2D 29 | , wallEnd :: Vertex2D 30 | , wallSector :: Sector 31 | , portalTo :: Maybe Sector 32 | , lowerTex :: WAD.LumpName 33 | , middleTex :: WAD.LumpName 34 | , upperTex :: WAD.LumpName 35 | } 36 | 37 | instance Show Wall where 38 | show _ = "I'm a wall" 39 | 40 | -- For floor and ceiling rendering 41 | data Subsector = Subsector { 42 | subsectorFloorPoints :: [Vertex2D] 43 | } deriving Show 44 | 45 | 46 | -- SECTORS --------------------------------------------------------------------- 47 | data TempSector = TempSector { 48 | rightSideDef :: WAD.SideDef 49 | , leftSideDef :: Maybe WAD.SideDef 50 | , rightSector :: Int 51 | , leftSector :: Maybe Int 52 | } 53 | 54 | -- TODO: terribly inefficient because of the list lookups 55 | extractSectors :: WAD.Level -> [Sector] 56 | extractSectors l@WAD.Level{..} 57 | = let (result, _) 58 | = foldr (\linedef (sectors, res) -> 59 | (insert' sectors res linedef, res) 60 | ) (initSectors, result) levelLineDefs 61 | in result 62 | where initSectors = map (\WAD.Sector{..} -> Sector { 63 | sectorWalls = [] 64 | , sectorCeiling = fromIntegral sectorCeilingHeight / scale 65 | , sectorFloor = fromIntegral sectorFloorHeight / scale 66 | }) levelSectors 67 | insert' secs res ld@WAD.LineDef{..} 68 | = secs' 69 | where secs' = updateAt secs rightSector (insertLine l res ld) 70 | --secs'' = case leftSector of 71 | -- Just justSect -> updateAt secs' justSect (\s -> insertLine l s result ld) 72 | -- Nothing -> secs' 73 | TempSector{..} = extractTempSector l ld 74 | 75 | extractTempSector :: WAD.Level -> WAD.LineDef -> TempSector 76 | extractTempSector WAD.Level{..} WAD.LineDef{..} 77 | = TempSector{..} 78 | where rightSideDef 79 | = levelSideDefs !! fromIntegral lineDefRightSideDef 80 | leftSideDef 81 | = ((levelSideDefs !!) . fromIntegral) <$> lineDefLeftSideDef 82 | rightSector 83 | = fromIntegral $ WAD.sideDefSector rightSideDef 84 | leftSector 85 | = (fromIntegral . WAD.sideDefSector) <$> leftSideDef 86 | 87 | updateAt :: [Sector] -> Int -> (Sector -> Sector) -> [Sector] 88 | updateAt secs at f 89 | = left ++ [f a] ++ right 90 | where (left, a : right) = splitAt at secs 91 | 92 | insertLine :: WAD.Level -> [Sector] -> WAD.LineDef -> Sector -> Sector 93 | insertLine l@WAD.Level{..} resSecs linedef@WAD.LineDef{..} sect@Sector{..} 94 | = sect { 95 | sectorWalls = Wall { 96 | wallStart = start 97 | , wallEnd = end 98 | , wallSector = resSecs !! rightSector 99 | , portalTo = (resSecs !!) <$> leftSector 100 | , lowerTex = WAD.sideDefLowerTextureName rightSideDef 101 | , middleTex = WAD.sideDefMiddleTextureName rightSideDef 102 | , upperTex = WAD.sideDefUpperTextureName rightSideDef 103 | } : sectorWalls 104 | } 105 | where TempSector{..} = extractTempSector l linedef 106 | (start, end) 107 | = (getVertex lineDefStartVertex, getVertex lineDefEndVertex) 108 | getVertex v 109 | = vertexToVect $ levelVertices !! fromIntegral v 110 | 111 | -- Group sectors by texture, and return the vertex data 112 | textToVertexData :: [Sector] -> M.Map WAD.LumpName [(V3 GLfloat, V2 GLfloat)] 113 | textToVertexData sectors 114 | = M.delete "-" textToVert' 115 | where textToVert' 116 | = M.fromList 117 | $ map (\xs@((tex, _) : _) -> (tex, concatMap snd xs)) 118 | $ groupBy (\(t1, _) (t2, _) -> t1 == t2) 119 | $ sortOn fst (sectorVertexBufferData sectors) 120 | 121 | sectorVertexBufferData :: [Sector] -> [(WAD.LumpName, [(V3 GLfloat, V2 GLfloat)])] 122 | sectorVertexBufferData sectors = do 123 | sector <- sectors 124 | Wall{..} <- sectorWalls sector 125 | let h1 = sectorFloor sector 126 | h2 = sectorCeiling sector 127 | case portalTo of 128 | Just otherSector -> 129 | let h1' = sectorFloor otherSector 130 | h2' = sectorCeiling otherSector 131 | in [ (lowerTex, quad wallStart wallEnd h1' h1) 132 | , (upperTex, quad wallStart wallEnd h2 h2') 133 | ] 134 | Nothing -> 135 | return (middleTex, quad wallStart wallEnd h2 h1) 136 | 137 | quad :: V2 GLfloat -> V2 GLfloat -> GLfloat -> GLfloat -> [(V3 GLfloat, V2 GLfloat)] 138 | quad (V2 x y) (V2 x' y') h' h 139 | = [ (V3 x h' y , V2 0 0) 140 | , (V3 x' h' y', V2 1 0) 141 | , (V3 x h y , V2 0 1) 142 | , (V3 x' h y', V2 1 1) 143 | ] 144 | 145 | -- SUBSECTORS ------------------------------------------------------------------ 146 | -- these are evil 147 | extractSubSectors :: WAD.Level -> [Subsector] 148 | extractSubSectors WAD.Level{..} 149 | = map (Subsector . subsectorPoints) levelSSectors 150 | where subsectorPoints :: WAD.SSector -> [Vertex2D] 151 | subsectorPoints WAD.SSector{..} 152 | = map (\WAD.Seg{..} -> 153 | vertexToVect $ levelVertices !! fromIntegral segStartVertex) 154 | $ take (fromIntegral ssectorSegCount) 155 | . drop (fromIntegral ssectorSegStart) 156 | $ levelSegs 157 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE Rank2Types #-} 10 | {-# LANGUAGE ImpredicativeTypes #-} 11 | module Main where 12 | import Control.Monad 13 | import Control.Monad.Reader 14 | import Data.CaseInsensitive hiding (map) 15 | import Data.Foldable 16 | import Data.IORef 17 | import Data.List hiding (map) 18 | import Data.Maybe 19 | import Data.Vector.V2 20 | import Enemy 21 | import Foreign 22 | import Game 23 | import Level.Sector 24 | import Graphics.GL.Core33 25 | import Graphics.GLUtils 26 | import Graphics.Shader 27 | import Graphics.Binding 28 | import Graphics.Program 29 | import Graphics.UI.GLFW 30 | import Linear 31 | import Sky 32 | import Sprite 33 | import TextureLoader 34 | import Types 35 | import Data.Var 36 | import Window 37 | import Render 38 | import Graphics.Triangulation.Delaunay 39 | import qualified Data.Map as M 40 | import qualified Game.Waddle as WAD 41 | 42 | 43 | width :: Int 44 | height :: Int 45 | (width, height) = (1280, 1024) 46 | 47 | type KeyMap = [(Key, Game ())] 48 | 49 | twoSidedLineDef :: WAD.LineDef -> Bool 50 | twoSidedLineDef WAD.LineDef{..} 51 | = isJust lineDefLeftSideDef 52 | 53 | main :: IO () 54 | main = do 55 | mainLoop <- initGL "E1M1" width height 56 | wad@WAD.Wad{..} <- WAD.load "doom.wad" 57 | let level@WAD.Level{..} = head $ toList wadLevels 58 | levelEnemies = [mkEnemy t | t <- levelThings, DEnemy _ <- [classifyThingType (WAD.thingType t)]] 59 | posThing = head $ 60 | filter (\t -> WAD.thingType t == WAD.Player1StartPos) levelThings 61 | posX = fromIntegral (WAD.thingX posThing) / scale 62 | posY = fromIntegral (WAD.thingY posThing) / scale 63 | sectors = extractSectors level 64 | 65 | let projTrans = perspective (0.75 :: GLfloat) 66 | (fromIntegral width / 67 | fromIntegral height) 68 | 1 69 | 400 70 | 71 | let textToVert = textToVertexData sectors 72 | dat = concatMap snd . M.toList $ textToVert 73 | sideDefCount = length dat 74 | elementBufferData 75 | = concat $ take sideDefCount $ 76 | iterate (map (+4)) ([0,1,2] ++ [2,1,3]) 77 | 78 | elementBufferId <- withNewPtr (glGenBuffers 1) 79 | glBindBuffer GL_ELEMENT_ARRAY_BUFFER elementBufferId 80 | withArrayLen elementBufferData $ \len elems -> 81 | glBufferData GL_ELEMENT_ARRAY_BUFFER 82 | (fromIntegral $ len * sizeOf (0 :: GLuint)) 83 | (elems :: Ptr GLuint) 84 | GL_STATIC_DRAW 85 | 86 | program@(Program progId) <- mkProgram wallVert textureFrag 87 | 88 | FragShaderLocation progId "outColor" $= FragDiffuseColor 89 | Uniform program proj $= projTrans 90 | 91 | levelRData <- forM (M.toList textToVert) $ \(texName, verts) -> do 92 | vertexBufferId <- withNewPtr (glGenBuffers 1) 93 | glBindBuffer GL_ARRAY_BUFFER vertexBufferId 94 | 95 | texId <- getTextureId wad texName 96 | 97 | vertexArrayId <- withNewPtr (glGenVertexArrays 1) 98 | glBindVertexArray vertexArrayId 99 | 100 | bindVertexData program verts 101 | 102 | return RenderData { 103 | rdVbo = vertexBufferId 104 | , rdEbo = elementBufferId 105 | , rdTex = texId 106 | , rdProg = program 107 | , rdVao = vertexArrayId 108 | , rdExtra = 0 109 | } 110 | 111 | --vertexBufferId <- withNewPtr (glGenBuffers 1) 112 | --glBindBuffer GL_ARRAY_BUFFER vertexBufferId 113 | 114 | --spriteProgram@(Program spriteProgId) <- mkProgram spriteVert spriteFrag 115 | 116 | -- floor 117 | let floorVertexBufferData 118 | = concatMap (\Sector{..} -> 119 | --let -- !xs = traceShowId $ map wallPoints sectorWalls 120 | -- -- !ys = traceShowId $ triangulation ts 121 | -- -- !asd = error $ show $ map wallPoints (chainWalls sectorWalls) 122 | -- ts = triangulation $ nub . concat $ map wallPoints (chainWalls sectorWalls) 123 | let ts = triangulate' $ nub . concat $ map wallPoints sectorWalls 124 | in map (\(V2 x y) -> 125 | V3 x sectorFloor y 126 | ) ts ++ 127 | map (\(V2 x y) -> 128 | V3 x sectorCeiling y 129 | ) ts 130 | ) sectors 131 | triangulate' points 132 | = map vector2Tov2 . concatMap (\(a, b, c) -> [a, b, c]) 133 | $ triangulate (map v2ToVector2 points) 134 | v2ToVector2 (V2 a b) = Vector2 (realToFrac a) (realToFrac b) 135 | wallPoints Wall{..} = [wallStart, wallEnd] 136 | findItem f [] = error "findItem: item not found" 137 | findItem f (x : xs) 138 | | f x = (x, xs) 139 | | otherwise = let (y, ys) = findItem f xs in (y, x : ys) 140 | chainWalls [] = [] 141 | chainWalls [w] = [w] 142 | chainWalls (w : ws) 143 | = let (w', ws') = findItem (\wall -> wallEnd wall == wallStart w) ws 144 | in w : chainWalls (w' : ws') 145 | --in case w' of 146 | -- [found] -> w : chainWalls (found : ws') 147 | -- [] -> [] 148 | vector2Tov2 (Vector2 a b) = V2 (realToFrac a) (realToFrac b) 149 | 150 | floorVertexBufferId <- withNewPtr (glGenBuffers 1) 151 | glBindBuffer GL_ARRAY_BUFFER floorVertexBufferId 152 | 153 | floorVertexArrayId <- withNewPtr (glGenVertexArrays 1) 154 | glBindVertexArray floorVertexArrayId 155 | 156 | floorProgram@(Program floorProgId) <- mkProgram floorVert floorFrag 157 | 158 | FragShaderLocation floorProgId "outColor" $= FragDiffuseColor 159 | Uniform floorProgram proj $= projTrans 160 | 161 | bindVertexData floorProgram floorVertexBufferData 162 | 163 | glEnable GL_DEPTH_TEST 164 | glEnable GL_BLEND 165 | glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA 166 | 167 | let playerPos = V3 posX 1.6 posY 168 | 169 | --texId <- getTextureId wad 170 | --let levelData = RenderData { rdVbo = vertexBufferId 171 | -- , rdEbo = elementBufferId 172 | -- , rdTex = texId 173 | -- , rdProg = program 174 | -- , rdVao = vertexArrayId 175 | -- } 176 | let floorRData = RenderData { rdVbo = floorVertexBufferId 177 | , rdEbo = 0 178 | , rdTex = 0 179 | , rdProg = floorProgram 180 | , rdVao = floorVertexArrayId 181 | , rdExtra = 0 182 | } 183 | 184 | spriteProg <- mkProgram spriteVert textureFrag 185 | Uniform spriteProg proj $= projTrans 186 | sprites <- createLevelThings wad spriteProg (WAD.levelThings level) 187 | let palette' = loadPalettes wad 188 | initState <- GameState <$> return program 189 | <*> return sideDefCount 190 | <*> pure levelRData 191 | <*> pure floorRData 192 | <*> pure sprites 193 | <*> newIORef undefined -- TODO: current sector 194 | <*> newIORef 0 195 | <*> newIORef playerPos 196 | <*> newIORef levelEnemies 197 | <*> pure (loadPalettes wad) 198 | <*> fillSkyTextureData wad 199 | <*> pistolWeapon wad palette' 200 | <*> newIORef 0 201 | <*> newIORef 0 202 | mainLoop (\w -> runGame (loop w (setMapping w)) initState) 203 | 204 | pistolWeapon :: WAD.Wad -> ColorPalette -> IO RenderData 205 | pistolWeapon wad palette = do 206 | wepProgram <- mkProgram staticVert textureFrag 207 | 208 | vaoId <- withNewPtr (glGenVertexArrays 1) 209 | glBindVertexArray vaoId 210 | 211 | vboId <- withNewPtr (glGenBuffers 1) 212 | glBindBuffer GL_ARRAY_BUFFER vboId 213 | 214 | let vbo = [ (V3 (-0.2) (-0.1) 0.0, V2 0.0 0.0) 215 | , (V3 0.2 (-0.1) 0.0, V2 1.0 0.0) 216 | , (V3 (-0.2) (-0.7) 0.0, V2 0.0 1.0) 217 | , (V3 0.2 (-0.7) 0.0, V2 1.0 1.0) 218 | ] 219 | ebo = [0, 1, 2, 220 | 2, 1, 3] 221 | 222 | bindVertexData wepProgram vbo 223 | 224 | eboId <- withNewPtr (glGenBuffers 1) 225 | glBindBuffer GL_ELEMENT_ARRAY_BUFFER eboId 226 | withArrayLen ebo $ \len vertices -> 227 | glBufferData GL_ELEMENT_ARRAY_BUFFER 228 | (fromIntegral $ len * sizeOf (0 :: GLuint)) 229 | (vertices :: Ptr GLuint) 230 | GL_STATIC_DRAW 231 | 232 | --still 233 | let wepSprite = fromMaybe (error "wep not found") 234 | (M.lookup (mk "PISGA0") (WAD.wadSprites wad)) 235 | let (tW, tH) = (fromIntegral $ WAD.pictureWidth $ WAD.spritePicture wepSprite, 236 | fromIntegral $ WAD.pictureHeight $ WAD.spritePicture wepSprite) 237 | txt <- loadSpriteColor wepSprite palette 238 | stillTexId <- withNewPtr (glGenTextures 1) 239 | glBindTexture GL_TEXTURE_2D stillTexId 240 | 241 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (fromIntegral GL_REPEAT) 242 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (fromIntegral GL_REPEAT) 243 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (fromIntegral GL_NEAREST) 244 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (fromIntegral GL_NEAREST) 245 | 246 | withArray txt $ 247 | glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_RGBA) tW tH 0 GL_RGBA GL_FLOAT 248 | 249 | --firing 250 | let fwepSprite = fromMaybe (error "fwep not found") 251 | (M.lookup (mk "PISFA0") (WAD.wadSprites wad)) 252 | let (fW, fH) = (fromIntegral $ WAD.pictureWidth $ WAD.spritePicture fwepSprite, 253 | fromIntegral $ WAD.pictureHeight $ WAD.spritePicture fwepSprite) 254 | ftxt <- loadSpriteColor fwepSprite palette 255 | firingTexId <- withNewPtr (glGenTextures 1) 256 | glBindTexture GL_TEXTURE_2D firingTexId 257 | 258 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (fromIntegral GL_REPEAT) 259 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (fromIntegral GL_REPEAT) 260 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (fromIntegral GL_NEAREST) 261 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (fromIntegral GL_NEAREST) 262 | 263 | withArray ftxt $ 264 | glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_RGBA) fW fH 0 GL_RGBA GL_FLOAT 265 | 266 | return RenderData { rdVbo = vboId, 267 | rdEbo = eboId, 268 | rdTex = stillTexId, 269 | rdExtra = firingTexId, 270 | rdVao = vaoId, 271 | rdProg = wepProgram} 272 | 273 | getTextureId :: WAD.Wad -> WAD.LumpName -> IO GLuint 274 | getTextureId wad name = do 275 | (tW, tH, txt) <- loadTexture wad name 276 | texId <- withNewPtr (glGenTextures 1) 277 | glBindTexture GL_TEXTURE_2D texId 278 | 279 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (fromIntegral GL_REPEAT) 280 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (fromIntegral GL_REPEAT) 281 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (fromIntegral GL_NEAREST) 282 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (fromIntegral GL_NEAREST) 283 | withArray txt $ 284 | glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_RGBA) tW tH 0 GL_RGBA GL_FLOAT 285 | return texId 286 | 287 | loop :: Window -> KeyMap -> Game () 288 | loop w mapping = do 289 | -- TODO: this is not very nice... 290 | ticks += 1 291 | rot' <- get rot 292 | (V3 px pz py) <- get player 293 | let ax = axisAngle (V3 0 1 0) rot' 294 | modelM = mkTransformationMat identity (V3 px (-pz) (-py)) 295 | lookM = mkTransformation ax (V3 0 0 0) 296 | (V4 x1 y1 z1 _) = lookM !* V4 0 0 1 1 297 | initV = V3 x1 y1 z1 298 | 299 | gameLogic 300 | updateView initV modelM 301 | keyEvents w mapping 302 | 303 | 304 | 305 | updateView :: V3 GLfloat -> M44 GLfloat -> Game () 306 | updateView initV modelM = do 307 | -- TODO: most of this stuff shouldn't be set on each update 308 | glEnable GL_CULL_FACE 309 | glFrontFace GL_CW 310 | glCullFace GL_BACK 311 | glClearColor 0 0 0 1 312 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (fromIntegral GL_REPEAT) 313 | glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT) 314 | prog'@(Program progId) <- asks prog 315 | glUseProgram progId 316 | 317 | Uniform prog' model $= modelM 318 | 319 | let viewTrans = lookAt (V3 0 0 0) 320 | initV 321 | (V3 0 1 0) :: M44 GLfloat 322 | 323 | Uniform prog' view $= viewTrans 324 | 325 | -- render the sky 326 | glDepthMask (fromBool False) 327 | sky' <- asks sky 328 | bindRenderData sky' 329 | glDrawElements GL_TRIANGLES 6 GL_UNSIGNED_INT nullPtr 330 | glDepthMask (fromBool True) 331 | 332 | --glDrawArrays GL_LINES 0 (fromIntegral ldefc * 4) 333 | --glPolygonMode GL_FRONT_AND_BACK GL_LINE 334 | sdefc <- asks sideDefs 335 | levelRd' <- asks levelRd 336 | 337 | forM_ levelRd' $ \level -> do 338 | bindRenderData level 339 | glBindVertexArray (rdVao level) 340 | glDrawElements GL_TRIANGLES (fromIntegral sdefc * 6) GL_UNSIGNED_INT nullPtr 341 | 342 | floorRd'@RenderData{rdProg} <- asks floorRd 343 | bindRenderData floorRd' 344 | --glPolygonMode GL_FRONT_AND_BACK GL_LINE 345 | glLineWidth 1 346 | glDrawArrays GL_TRIANGLES 0 50000 -- TODO: need actual number 347 | glPolygonMode GL_FRONT_AND_BACK GL_FILL 348 | 349 | Uniform rdProg model $= modelM 350 | Uniform rdProg view $= viewTrans 351 | 352 | -- TODO: can be optimized to only bind program once... 353 | sprites' <- asks sprites 354 | forM_ sprites' $ \Sprite{..} -> do 355 | RenderData{rdProg} <- return spriteRenderData 356 | Uniform rdProg model $= modelM 357 | Uniform rdProg view $= viewTrans 358 | bindRenderData spriteRenderData 359 | glDrawElements GL_TRIANGLES 6 GL_UNSIGNED_INT nullPtr 360 | 361 | -- render wep 362 | weapon <- asks pWeapon 363 | bindRenderData weapon 364 | ticks' <- asks ticks 365 | lastShot' <- asks lastShot 366 | ticks'' <- liftIO $ readIORef ticks' 367 | lastShot'' <- liftIO $ readIORef lastShot' 368 | when (ticks'' - lastShot'' <= 25) $ 369 | glBindTexture GL_TEXTURE_2D (rdExtra weapon) 370 | glDrawElements GL_TRIANGLES 6 GL_UNSIGNED_INT nullPtr 371 | 372 | -- this is a huge mess 373 | -- 374 | 375 | extendToV4 :: V3 GLfloat -> V4 GLfloat 376 | extendToV4 (V3 x z y) = V4 x z y 1 377 | 378 | multAndProject :: M44 GLfloat -> V3 GLfloat -> V3 GLfloat 379 | multAndProject m v = 380 | let (V4 x y z _) = m !* extendToV4 v 381 | in V3 x y z 382 | 383 | applyShot :: Game () 384 | applyShot = return () 385 | 386 | -- TODO: no need to recalculate every time, only when rotating 387 | moveVector :: Game (V3 GLfloat) 388 | moveVector = do 389 | rot' <- get rot 390 | let ax = axisAngle (V3 0 1 0) rot' 391 | lookM = mkTransformation ax (V3 0 0 0) 392 | (V4 x1 y1 z1 _) = lookM !* V4 0 0 1 1 393 | move = V3 (-x1) y1 z1 394 | return move 395 | 396 | keyEvents :: Window -> KeyMap -> Game () 397 | keyEvents w mapping 398 | = forM_ mapping $ \(key, action) -> do 399 | k <- liftIO $ getKey w key 400 | when (k == KeyState'Pressed) action 401 | 402 | setMapping :: Window -> KeyMap 403 | setMapping w 404 | = [ (Key'Space, shoot) 405 | , (Key'W, moveForward) 406 | , (Key'S, moveBackwards) 407 | , (Key'D, turnRight) 408 | , (Key'A, turnLeft) 409 | , (Key'Up, moveUp) 410 | , (Key'Down, moveDown) 411 | , (Key'Left, moveLeft) 412 | , (Key'Right, moveRight) 413 | , (Key'Escape, quit w) 414 | ] 415 | 416 | -- Actions 417 | quit :: Window -> Game () 418 | quit w = liftIO $ setWindowShouldClose w True 419 | 420 | moveBy :: V3 GLfloat -> Game () 421 | moveBy by = do 422 | let moveM = mkTransformationMat identity by 423 | player $~ multAndProject moveM 424 | 425 | shoot :: Game () 426 | shoot = do 427 | ticks' <- get ticks 428 | lastShot $= ticks' 429 | applyShot 430 | 431 | moveLeft :: Game () 432 | moveLeft = do 433 | (V3 v1 v2 v3) <- moveVector 434 | moveBy (V3 (-v3) v2 v1) 435 | 436 | moveRight :: Game () 437 | moveRight = do 438 | (V3 v1 v2 v3) <- moveVector 439 | moveBy (V3 v3 v2 (-v1)) 440 | 441 | moveDown :: Game () 442 | moveDown 443 | = moveBy (V3 0 (-0.2) 0) 444 | 445 | moveUp :: Game () 446 | moveUp 447 | = moveBy (V3 0 0.2 0) 448 | 449 | moveForward :: Game () 450 | moveForward 451 | = join $ moveBy <$> moveVector 452 | 453 | moveBackwards :: Game () 454 | moveBackwards 455 | = join $ moveBy . negate <$> moveVector 456 | 457 | turnLeft :: Game () 458 | turnLeft = rot += 0.05 459 | 460 | turnRight :: Game () 461 | turnRight = rot -= 0.05 462 | -------------------------------------------------------------------------------- /src/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Render where 4 | import Control.Monad.IO.Class 5 | import Graphics.GL 6 | import Linear 7 | import Graphics.Program 8 | import qualified Game.Waddle as WAD 9 | 10 | type Vertex2D = V2 GLfloat 11 | 12 | vertexToVect :: WAD.Vertex -> V2 GLfloat 13 | vertexToVect (WAD.Vertex x y) 14 | = V2 (-fromIntegral x / scale) (fromIntegral y / scale) 15 | 16 | scale :: GLfloat 17 | scale = 16 18 | 19 | data RenderData = forall u i. RenderData { 20 | rdVbo :: GLuint 21 | , rdEbo :: GLuint 22 | , rdVao :: GLuint 23 | , rdTex :: GLuint 24 | , rdProg :: Program u i 25 | , rdExtra :: GLuint 26 | } 27 | 28 | bindRenderData :: MonadIO m => RenderData -> m () 29 | bindRenderData RenderData{..} = do 30 | let (Program progId) = rdProg 31 | glUseProgram progId 32 | glBindVertexArray rdVao 33 | glBindBuffer GL_ELEMENT_ARRAY_BUFFER rdEbo 34 | glBindTexture GL_TEXTURE_2D rdTex 35 | 36 | -------------------------------------------------------------------------------- /src/Sky.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Sky where 3 | import qualified Game.Waddle as WAD 4 | import Foreign 5 | import Graphics.GL.Core33 6 | import Graphics.GLUtils 7 | import Graphics.Shader 8 | import TextureLoader 9 | import Graphics.Binding 10 | import Graphics.Program 11 | import Render 12 | import Linear 13 | 14 | fillSkyTextureData :: WAD.Wad -> IO RenderData 15 | fillSkyTextureData wad = do 16 | -- TODO: figure out which SKY texture 17 | skyProgram <- mkProgram staticVert textureFrag 18 | 19 | vaoId <- withNewPtr (glGenVertexArrays 1) 20 | glBindVertexArray vaoId 21 | 22 | vboId <- withNewPtr (glGenBuffers 1) 23 | glBindBuffer GL_ARRAY_BUFFER vboId 24 | 25 | bindVertexData skyProgram vbo 26 | 27 | eboId <- withNewPtr (glGenBuffers 1) 28 | glBindBuffer GL_ELEMENT_ARRAY_BUFFER eboId 29 | withArrayLen ebo $ \len vertices -> 30 | glBufferData GL_ELEMENT_ARRAY_BUFFER 31 | (fromIntegral $ len * sizeOf (0 :: GLuint)) 32 | (vertices :: Ptr GLuint) 33 | GL_STATIC_DRAW 34 | 35 | (tW, tH, txt) <- loadTexture wad "SKY1" 36 | texId <- withNewPtr (glGenTextures 1) 37 | glBindTexture GL_TEXTURE_2D texId 38 | 39 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (fromIntegral GL_REPEAT) 40 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (fromIntegral GL_REPEAT) 41 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (fromIntegral GL_NEAREST) 42 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (fromIntegral GL_NEAREST) 43 | 44 | withArray txt $ 45 | glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_RGBA) tW tH 0 GL_RGBA GL_FLOAT 46 | 47 | return RenderData { rdVbo = vboId 48 | , rdEbo = eboId 49 | , rdTex = texId 50 | , rdVao = vaoId 51 | , rdProg = skyProgram 52 | } 53 | where 54 | vbo = [ (V3 (-1.0) 1.0 0.0, V2 0.0 0.0) 55 | , (V3 1.0 1.0 0.0, V2 1.0 0.0) 56 | , (V3 (-1.0) (-1.0) 0.0, V2 0.0 1.0) 57 | , (V3 1.0 (-1.0) 0.0, V2 1.0 1.0) 58 | ] 59 | 60 | ebo = [0, 1, 2, 61 | 2, 1, 3] 62 | -------------------------------------------------------------------------------- /src/Sprite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module Sprite where 3 | import Control.Monad 4 | import Data.CaseInsensitive hiding (map) 5 | import Data.IORef 6 | import Data.Array.IO as AI 7 | import qualified Data.ByteString as BS 8 | import qualified Data.ByteString.Char8 as BSC 9 | import qualified Data.Map as M 10 | import Data.Maybe 11 | import Data.Char 12 | import Foreign 13 | import Game 14 | import qualified Game.Waddle as WAD 15 | import Graphics.GLUtils 16 | import Graphics.Program 17 | import Graphics.Shader 18 | import Graphics.TupleList 19 | import Graphics.GL.Core33 20 | import Linear 21 | import TextureLoader 22 | import SpriteMap 23 | import Graphics.Binding 24 | import Render 25 | 26 | type SpriteArgs = '[Pos3, VertexPos, Tex2] 27 | 28 | testSpriteVbo :: [GLfloat] 29 | testSpriteVbo = [ 30 | -0.5, 0.5, 0.0, 0.0, 0.0, 31 | 0.5, 0.5, 0.0, 1.0, 0.0, 32 | -0.5, -0.5, 0.0, 0.0, 1.0, 33 | 0.5, -0.5, 0.0, 1.0, 1.0] 34 | 35 | testSpriteEbo :: [GLuint] 36 | testSpriteEbo = [ 37 | 0, 1, 2, 38 | 2, 1, 3] 39 | 40 | loadSpriteColor :: WAD.Sprite -> ColorPalette -> IO [GLfloat] 41 | loadSpriteColor sprite cp 42 | = unpackTuples <$> (textureDataToColor cp <$> loadSprite sprite) 43 | 44 | loadSprite :: WAD.Sprite -> IO [Word8] 45 | loadSprite sprite = do 46 | let pic = WAD.spritePicture sprite 47 | let fW = WAD.pictureWidth pic 48 | let fH = WAD.pictureHeight pic 49 | pxArr <- AI.newArray (0, fW * fH) (0xFF :: Word8) 50 | :: IO (IOArray Int Word8) 51 | let posts = WAD.picturePosts pic 52 | forM_ (zip [0..] posts) $ \(x, col) -> 53 | forM_ col $ \post -> do 54 | let tx = x 55 | forM_ (zip [0..] (BS.unpack $ WAD.postPixels post)) $ \(i, pt) -> do 56 | let ty = fromIntegral (WAD.postTop post) + i 57 | when (tx <= fW - 1 && ty <= fH - 1 && tx >= 0 && ty >= 0) $ 58 | writeArray pxArr (tx + ty * fW) pt 59 | getElems pxArr 60 | 61 | createLevelThings :: WAD.Wad -> Program SpriteArgs i -> [WAD.Thing] -> IO [Sprite] 62 | createLevelThings wad prog things 63 | = forM notReserved (\t -> makeSprite' (mkVbo t) (mkEbo t) (Just t) wad prog (thingToSprite $ WAD.thingType t)) 64 | where 65 | notReserved = filter (\t -> thingTypeToInt (WAD.thingType t) `notElem` reservedSpriteIds) things 66 | pW = 2 -- fixME, ugly 67 | pH = 3 -- fixME, ugly 68 | tx t = fromIntegral (WAD.thingX t) / scale 69 | ty t = fromIntegral (WAD.thingY t) / scale 70 | mkVbo t = [ (V3 (-tx t) pH (ty t), V1 (-pW), V2 1 0) 71 | , (V3 (-tx t) pH (ty t), V1 pW, V2 0 0) 72 | , (V3 (-tx t) 0 (ty t), V1 (-pW), V2 1 1) 73 | , (V3 (-tx t) 0 (ty t), V1 pW, V2 0 1) 74 | ] 75 | mkEbo t = [ 76 | 0, 1, 2, 77 | 2, 1, 3] 78 | 79 | --makeSprite :: TypeInfo u => WAD.Wad -> Program u i -> WAD.LumpName -> IO Sprite 80 | --makeSprite 81 | -- = makeSprite' testSpriteVbo testSpriteEbo Nothing 82 | 83 | findSpriteName :: WAD.Wad -> WAD.LumpName -> WAD.LumpName 84 | findSpriteName wad name 85 | = findSpriteName' "A" "0" 86 | where 87 | findSpriteName' f@(a : as) g@(b : bs) 88 | | isNothing p = findSpriteName' (na : as) (nb : bs) 89 | | otherwise = t 90 | where 91 | p = M.lookup (mk t) (WAD.wadSprites wad) 92 | t = BS.append (BS.append name (BSC.pack f)) (BSC.pack g) 93 | na = chr $ ord a + 1 94 | nb = chr $ ord b + 1 95 | 96 | makeSprite' :: [FromList (ArgMap SpriteArgs)] -> [GLuint] -> Maybe WAD.Thing -> WAD.Wad -> Program SpriteArgs i -> WAD.LumpName -> IO Sprite 97 | makeSprite' vbo ebo thing wad program spriteName' = do 98 | let spriteName = if length (BS.unpack spriteName') == 4 then 99 | findSpriteName wad spriteName' 100 | else 101 | spriteName' 102 | 103 | vaoId <- withNewPtr (glGenVertexArrays 1) 104 | glBindVertexArray vaoId 105 | 106 | vboId <- withNewPtr (glGenBuffers 1) 107 | glBindBuffer GL_ARRAY_BUFFER vboId 108 | 109 | bindVertexData program vbo 110 | 111 | eboId <- withNewPtr (glGenBuffers 1) 112 | glBindBuffer GL_ELEMENT_ARRAY_BUFFER eboId 113 | withArrayLen ebo $ \len vertices -> 114 | glBufferData GL_ELEMENT_ARRAY_BUFFER 115 | (fromIntegral $ len * sizeOf (0 :: GLuint)) 116 | (vertices :: Ptr GLuint) 117 | GL_STATIC_DRAW 118 | 119 | -- load sprite image 120 | let sprite = fromMaybe (error ("invalid sprite " ++ BSC.unpack spriteName)) 121 | (M.lookup (mk spriteName) (WAD.wadSprites wad)) 122 | let loadedPalette = loadPalettes wad 123 | p <- loadSprite sprite 124 | let spritePixels = unpackTuples (textureDataToColor loadedPalette p) 125 | let sW = fromIntegral $ WAD.pictureWidth $ WAD.spritePicture sprite 126 | let sH = fromIntegral $ WAD.pictureHeight $ WAD.spritePicture sprite 127 | texId <- withNewPtr (glGenTextures 1) 128 | glBindTexture GL_TEXTURE_2D texId 129 | 130 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (fromIntegral GL_REPEAT) 131 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (fromIntegral GL_REPEAT) 132 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (fromIntegral GL_NEAREST) 133 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (fromIntegral GL_NEAREST) 134 | withArray spritePixels $ 135 | glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_RGBA) sW sH 0 GL_RGBA GL_FLOAT 136 | 137 | let renderData = RenderData { 138 | rdVao = vaoId 139 | , rdVbo = vboId 140 | , rdTex = texId 141 | , rdProg = program 142 | , rdEbo = eboId 143 | } 144 | 145 | -- TODO: what is this?! 146 | let v3 = case thing of 147 | Nothing -> V3 0 0 0 148 | Just jt -> V3 (fromIntegral $ WAD.thingX jt) 0.0 (fromIntegral $ WAD.thingY jt) 149 | 150 | Sprite <$> pure "Lev" 151 | <*> newIORef False 152 | <*> newIORef 0 153 | <*> pure renderData 154 | <*> pure v3 155 | -------------------------------------------------------------------------------- /src/SpriteMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SpriteMap where 3 | import Enemy () 4 | 5 | import qualified Game.Waddle as WAD 6 | import Data.Maybe 7 | 8 | thingToSprite :: WAD.ThingType -> WAD.LumpName 9 | thingToSprite t 10 | = fromMaybe (error "NO THING") 11 | (lookup (thingTypeToInt t) thingIdToSprite) 12 | 13 | reservedSpriteIds = [-1, 0, 1, 2, 3, 4, 11, 14] 14 | 15 | thingTypeToInt :: Integral a => WAD.ThingType -> a 16 | thingTypeToInt t 17 | = thingTypeToInt' t [0..3006] 18 | where 19 | thingTypeToInt' t [] 20 | = error "lol no" 21 | thingTypeToInt' t (x : xs) 22 | | t == WAD.thingTypeFromNumber x = x 23 | | otherwise = thingTypeToInt' t xs 24 | 25 | thingIdToSprite = [ 26 | ((-1),"ffff"), 27 | (0,"0000"), 28 | (1,"PLAY"), 29 | (2,"PLAY"), 30 | (3,"PLAY"), 31 | (4,"PLAY"), 32 | (11,"----"), 33 | (14,"----"), 34 | (3004,"POSS"), 35 | (84,"SSWV"), 36 | (9,"SPOS"), 37 | (65,"CPOS"), 38 | (3001,"TROO"), 39 | (3002,"SARG"), 40 | (58,"SARG"), 41 | (3006,"SKUL"), 42 | (3005,"HEAD"), 43 | (69,"BOS2"), 44 | (3003,"BOSS"), 45 | (68,"BSPI"), 46 | (71,"PAIN"), 47 | (66,"SKEL"), 48 | (67,"FATT"), 49 | (64,"VILE"), 50 | (7,"SPID"), 51 | (16,"CYBR"), 52 | (88,"BBRN"), 53 | (89,"-"), 54 | (87,"-"), 55 | (2005,"CSAW"), 56 | (2001,"SHOT"), 57 | (82,"SGN2"), 58 | (2002,"MGUN"), 59 | (2003,"LAUN"), 60 | (2004,"PLAS"), 61 | (2006,"BFUG"), 62 | (2007,"CLIP"), 63 | (2008,"SHEL"), 64 | (2010,"ROCK"), 65 | (2047,"CELL"), 66 | (2048,"AMMO"), 67 | (2049,"SBOX"), 68 | (2046,"BROK"), 69 | (17,"CELP"), 70 | (8,"BPAK"), 71 | (2011,"STIM"), 72 | (2012,"MEDI"), 73 | (2014,"BON1"), 74 | (2015,"BON2"), 75 | (2018,"ARM1"), 76 | (2019,"ARM2"), 77 | (83,"MEGA"), 78 | (2013,"SOUL"), 79 | (2022,"PINV"), 80 | (2023,"PSTR"), 81 | (2024,"PINS"), 82 | (2025,"SUIT"), 83 | (2026,"PMAP"), 84 | (2045,"PVIS"), 85 | (5,"BKEY"), 86 | (40,"BSKU"), 87 | (13,"RKEY"), 88 | (38,"RSKU"), 89 | (6,"YKEY"), 90 | (39,"YSKU"), 91 | (2035,"BAR1"), 92 | (72,"KEEN"), 93 | (48,"ELEC"), 94 | (30,"COL1"), 95 | (32,"COL3"), 96 | (31,"COL2"), 97 | (36,"COL5"), 98 | (33,"COL4"), 99 | (37,"COL6"), 100 | (47,"SMIT"), 101 | (43,"TRE1"), 102 | (54,"TRE2"), 103 | (2028,"COLU"), 104 | (85,"TLMP"), 105 | (86,"TLP2"), 106 | (34,"CAND"), 107 | (35,"CBRA"), 108 | (44,"TBLU"), 109 | (45,"TGRE"), 110 | (46,"TRED"), 111 | (55,"SMBT"), 112 | (56,"SMGT"), 113 | (57,"SMRT"), 114 | (70,"FCAN"), 115 | (41,"CEYE"), 116 | (42,"FSKU"), 117 | (49,"GOR1"), 118 | (63,"GOR1"), 119 | (50,"GOR2"), 120 | (59,"GOR2"), 121 | (52,"GOR4"), 122 | (60,"GOR4"), 123 | (51,"GOR3"), 124 | (61,"GOR3"), 125 | (53,"GOR5"), 126 | (62,"GOR5"), 127 | (73,"HDB1"), 128 | (74,"HDB2"), 129 | (75,"HDB3"), 130 | (76,"HDB4"), 131 | (77,"HDB5"), 132 | (78,"HDB6"), 133 | (25,"POL1"), 134 | (26,"POL6"), 135 | (27,"POL4"), 136 | (28,"POL2"), 137 | (29,"POL3"), 138 | (10,"PLAY"), 139 | (12,"PLAY"), 140 | (24,"POL5"), 141 | (79,"POB1"), 142 | (80,"POB2"), 143 | (81,"BRS1"), 144 | (15,"PLAY"), 145 | (18,"POSS"), 146 | (19,"SPOS"), 147 | (20,"TROO"), 148 | (21,"SARG"), 149 | (22,"HEAD"), 150 | (23,"SKUL")] 151 | -------------------------------------------------------------------------------- /src/TextureLoader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module TextureLoader 4 | ( loadTexture 5 | , loadPalettes 6 | , ColorPalette 7 | , unpackTuples 8 | , textureDataToColor 9 | , getColor 10 | ) 11 | where 12 | 13 | import Control.Monad 14 | import Control.Monad.Reader 15 | import Data.Array.IO as AI 16 | import qualified Data.ByteString as BS 17 | import Data.CaseInsensitive 18 | import Data.Map.Lazy as Map 19 | import Data.Maybe 20 | import Data.Word 21 | import qualified Game.Waddle as WAD 22 | import Graphics.GL.Core33 23 | import Graphics.GL.Functions 24 | import Game 25 | 26 | loadPalettes :: WAD.Wad -> ColorPalette 27 | loadPalettes wad 28 | | isNothing pals = [] 29 | | otherwise = p 30 | where 31 | pals@(~(Just (WAD.Palettes p))) = WAD.wadPalettes wad 32 | 33 | textureDataToColor :: ColorPalette -> [Word8] -> [(GLfloat, GLfloat, GLfloat, GLfloat)] 34 | textureDataToColor palette words 35 | = (\i -> getColor (fromIntegral i) palette) <$> words 36 | 37 | getColor :: Int -> ColorPalette -> (GLfloat, GLfloat, GLfloat, GLfloat) 38 | getColor 0xFF cp 39 | = (0.0, 0.0, 0.0, 0.0) 40 | getColor n cp 41 | = (\(r, g, b) -> (fromIntegral r / 255, fromIntegral g / 255, fromIntegral b / 255, 1.0)) 42 | . (!! n) . head $ cp 43 | 44 | unpackTuples :: [(a, a, a, a)] -> [a] 45 | unpackTuples = concatMap (\(r, g, b, a) -> [r, g, b, a]) 46 | 47 | loadTexture :: WAD.Wad -> WAD.LumpName -> IO (GLsizei, GLsizei, [GLfloat]) 48 | loadTexture wad' name = do 49 | let myTex = fromJust (Map.lookup (mk name) (WAD.wadTextures wad')) 50 | let texWidth = fromIntegral $ WAD.textureWidth myTex 51 | let texHeight = fromIntegral $ WAD.textureHeight myTex 52 | let loadedPalette = loadPalettes wad' 53 | pxArr <- liftIO (AI.newArray (0, texWidth*texHeight) (0xFF :: Word8) 54 | :: IO (IOArray Int Word8)) 55 | forM_ (WAD.texturePatchDescriptors myTex) $ \desc -> do 56 | let bx = fromIntegral $ WAD.patchDescriptorXOffset desc 57 | by = fromIntegral $ WAD.patchDescriptorYOffset desc 58 | idx = fromIntegral $ WAD.patchDescriptorPNameIndex desc 59 | lname = fromJust $ Map.lookup idx (WAD.wadPNames wad') 60 | patch = fromJust $ Map.lookup (mk lname) (WAD.wadPatches wad') 61 | let posts = WAD.picturePosts $ WAD.patchPicture patch 62 | forM_ (zip [0..] posts) $ \(x, col) -> 63 | forM_ col $ \post -> do 64 | let tx = bx + x 65 | forM_ (zip [0..] (BS.unpack $ WAD.postPixels post)) $ \(i, pt) -> do 66 | let ty = by + fromIntegral (WAD.postTop post) + i 67 | when (tx <= texWidth - 1 && ty <= texHeight - 1 && tx >= 0 && ty >= 0) $ 68 | liftIO (writeArray pxArr (tx + ty * texWidth) pt) 69 | final <- liftIO $ getElems pxArr 70 | return (fromIntegral texWidth, 71 | fromIntegral texHeight, 72 | unpackTuples (textureDataToColor loadedPalette final)) 73 | -------------------------------------------------------------------------------- /src/Triangulation.hs: -------------------------------------------------------------------------------- 1 | module Triangulation where 2 | import Linear hiding (cross) 3 | import Data.List 4 | 5 | clockwise :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool 6 | clockwise o a b = (a - o) `cross` (b - o) <= 0 7 | 8 | collinear :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool 9 | collinear o a b = (a - o) `cross` (b - o) == 0 10 | 11 | cross :: Num a => V2 a -> V2 a -> a 12 | cross (V2 x1 y1) (V2 x2 y2) = x1 * y2 - x2 * y1 13 | 14 | pointInTriangle p a b c 15 | = let cw1 = clockwise a p b 16 | cw2 = clockwise b p c 17 | cw3 = clockwise c p a 18 | in cw1 == cw2 && cw2 == cw3 19 | 20 | ear :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> [V2 a] -> Bool 21 | ear p1 mid p2 xs 22 | = clockwise p1 mid p2 && not (any (\p -> pointInTriangle p p1 mid p2) xs) 23 | 24 | triangulation :: (Show a, Num a, Ord a) => [V2 a] -> [V2 a] 25 | triangulation [a, b, c] 26 | = [a, b, c] 27 | triangulation (a : b : c : xs) 28 | -- | not (collinear a b c) && ear a b c xs = [a, b, c] ++ triangulation (a : c : xs) 29 | | collinear a b c = triangulation (a : c : xs) 30 | | ear a b c xs = [a, b, c] ++ triangulation (a : c : xs) 31 | | otherwise = triangulation (b : c : xs ++ [a]) 32 | triangulation x = x 33 | 34 | test = nub $ concat [[V2 (-95.0) (-198.0),V2 (-104.5) (-194.0)],[V2 (-104.5) (-194.0),V2 (-118.5) (-194.0)],[V2 (-118.5) (-194.0),V2 (-127.5) (-196.5)],[V2 (-127.5) (-196.5),V2 (-133.0) (-204.5)],[V2 (-133.0) (-204.5),V2 (-129.0) (-213.0)],[V2 (-129.0) (-213.0),V2 (-111.5) (-215.5)],[V2 (-111.5) (-215.5),V2 (-96.5) (-211.5)],[V2 (-96.5) (-211.5),V2 (-95.0) (-198.0)]] 35 | 36 | --(-95.0) (-198.0)( -104.5) (-194.0) (-104.5) (-194.0) (-118.5) (-194.0) (-118.5) (-194.0) (-127.5) (-196.5) (-127.5) (-196.5) (-133.0) (-204.5) (-133.0) (-204.5) (-129.0) (-213.0) (-129.0) (-213.0) (-111.5) (-215.5) (-111.5) (-215.5) (-96.5) (-211.5) (-96.5) (-211.5) (-95.0) (-198.0) 37 | 38 | 39 | -- (-118.5) (-194.0) (-127.5) (-196.5) (-133.0) (-204.5) (-129.0) (-213.0) (-111.5) (-215.5) (-96.5) (-211.5) (-104.5) (-194.0) 40 | 41 | findItem f [] = error "findItem: item not found" 42 | findItem f (x : xs) 43 | | f x = (x, xs) 44 | | otherwise = let (y, ys) = findItem f xs in (y, x : ys) 45 | 46 | stuff = [[V2 (-86.0) (-200.0),V2 (-86.0) (-194.0)],[V2 (-86.0) (-194.0),V2 (-86.0) (-184.0)],[V2 (-86.0) (-184.0),V2 (-92.0) (-180.0)],[V2 (-92.0) (-180.0),V2 (-104.0) (-180.0)],[V2 (-104.0) (-180.0),V2 (-116.0) (-180.0)],[V2 (-116.0) (-180.0),V2 (-120.0) (-182.5)],[V2 (-120.0) (-182.5),V2 (-136.0) (-182.5)],[V2 (-136.0) (-182.5),V2 (-140.0) (-182.5)],[V2 (-140.0) (-182.5),V2 (-142.0) (-188.0)],[V2 (-142.0) (-188.0),V2 (-152.0) (-194.5)],[V2 (-152.0) (-194.5),V2 (-171.0) (-194.5)],[V2 (-171.0) (-194.5),V2 (-171.0) (-210.0)],[V2 (-171.0) (-210.0),V2 (-171.0) (-228.0)],[V2 (-171.0) (-228.0),V2 (-140.0) (-228.0)],[V2 (-140.0) (-228.0),V2 (-124.0) (-228.0)],[V2 (-124.0) (-228.0),V2 (-86.0) (-228.0)],[V2 (-86.0) (-228.0),V2 (-86.0) (-220.0)],[V2 (-86.0) (-220.0),V2 (-86.0) (-212.0)],[V2 (-86.0) (-212.0),V2 (-86.0) (-210.0)],[V2 (-86.0) (-210.0),V2 (-86.0) (-204.0)]] 47 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | 4 | import Linear 5 | import Graphics.GL.Core33 6 | import qualified Game.Waddle.Types as WAD 7 | import Game.Waddle.Types (ThingType(..)) 8 | 9 | 10 | type Pos = V3 GLfloat 11 | 12 | data DType 13 | = StartPos Int 14 | | DEnemy ThingType 15 | | PickUp ThingType 16 | | Object ThingType 17 | | Unknown 18 | 19 | classifyThingType :: WAD.ThingType -> DType 20 | classifyThingType c = case c of 21 | ZeroThing -> Unknown 22 | Player1StartPos -> StartPos 1 23 | Player2StartPos -> StartPos 2 24 | Player3StartPos -> StartPos 3 25 | Player4StartPos -> StartPos 4 26 | DeathMatchStartPos -> StartPos 5 27 | FormerHuman -> DEnemy c 28 | WolfensteinOfficer -> DEnemy c 29 | FormerHumanSergeant -> DEnemy c 30 | FormerHumanCommando -> DEnemy c 31 | Imp -> DEnemy c 32 | Demon -> DEnemy c 33 | Spectre -> DEnemy c 34 | LostSoul -> DEnemy c 35 | Cacodemon -> DEnemy c 36 | HellKnight -> DEnemy c 37 | BaronOfHell -> DEnemy c 38 | Arachnotron -> DEnemy c 39 | PainElemental -> DEnemy c 40 | Revenant -> DEnemy c 41 | Mancubus -> DEnemy c 42 | ArchVile -> DEnemy c 43 | Spiderdemon -> DEnemy c 44 | Cyberdemon -> DEnemy c 45 | BossBrain -> DEnemy c 46 | TeleportLanding -> Unknown 47 | BossShooter -> Unknown 48 | SpawnSpot -> Unknown 49 | Chainsaw -> PickUp c 50 | Shotgun -> PickUp c 51 | SuperShotgun -> PickUp c 52 | Chaingun -> PickUp c 53 | RocketLauncher -> PickUp c 54 | Plasmagun -> PickUp c 55 | BFG9000 -> PickUp c 56 | AmmoClip -> PickUp c 57 | ShotgunShells -> PickUp c 58 | Rocket -> PickUp c 59 | CellCharge -> PickUp c 60 | BoxOfAmmo -> PickUp c 61 | BoxOfShells -> PickUp c 62 | BoxOfRockets -> PickUp c 63 | CellChargePack -> PickUp c 64 | Backpack -> PickUp c 65 | StimPack -> PickUp c 66 | Medikit -> PickUp c 67 | HealthPotion -> PickUp c 68 | SpiritArmor -> PickUp c 69 | SecurityArmor -> PickUp c 70 | CombatArmor -> PickUp c 71 | MegaSphere -> PickUp c 72 | SoulSphere -> PickUp c 73 | Invulnerability -> PickUp c 74 | BerserkPack -> PickUp c 75 | Invisibility -> PickUp c 76 | RadiationSuit -> PickUp c 77 | ComputerMap -> PickUp c 78 | LightAmplificationGoggles -> PickUp c 79 | BlueKeyCard -> PickUp c 80 | RedKeyCard -> PickUp c 81 | YellowKeyCard -> PickUp c 82 | BlueSkullKey -> PickUp c 83 | RedSkullKey -> PickUp c 84 | YellowSkullKey -> PickUp c 85 | Barrel -> Object c 86 | BurningBarrel -> Object c 87 | Candle -> Object c 88 | Candelabra -> Object c 89 | TallTechnocolumn -> Object c 90 | TallGreenPillar -> Object c 91 | TallRedPillar -> Object c 92 | ShortGreenPillar -> Object c 93 | ShortGreenPillarWithHeart -> Object c 94 | ShortGreenPillarWithBeatingHeart -> Object c 95 | ShortRedPillar -> Object c 96 | ShortRedPillarWithSkull -> Object c 97 | Stalagmite -> Object c 98 | BurntGrayTree -> Object c 99 | LargeBrownTree -> Object c 100 | TallBlueFirestick -> Object c 101 | TallGreenFirestick -> Object c 102 | TallRedFirestick -> Object c 103 | ShortBlueFirestick -> Object c 104 | ShortGreenFirestick -> Object c 105 | ShortRedFirestick -> Object c 106 | FloorLamp -> Object c 107 | TallTechnoLamp -> Object c 108 | ShortTechnoLamp -> Object c 109 | EvilEyeSymbol -> Object c 110 | FlamingSkullRock -> Object c 111 | ImpaledHuman -> Object c 112 | TwitchingImpaledHuman -> Object c 113 | SkullOnPole -> Object c 114 | FiveSkullShishKebap -> Object c 115 | PileOfSkullsAndCandles -> Object c 116 | HangingVictim -> Object c 117 | HangingVictimTwitching -> Object c 118 | HangingPairOfLegs -> Object c 119 | HangingVictim1Leg -> Object c 120 | HangingLeg -> Object c 121 | HangingVictimNoGuts -> Object c 122 | HangingVictimNoGutsBrain -> Object c 123 | HangingTorsoLookingDown -> Object c 124 | HangingTorsoOpenSkull -> Object c 125 | HangingTorsoLookingUp -> Object c 126 | HangingTorsoNoBrain -> Object c 127 | HangingBilly -> Object c 128 | DeadPlayer -> Object c 129 | DeadFormerHuman -> Object c 130 | DeadFormerSergeant -> Object c 131 | DeadImp -> Object c 132 | DeadDemon -> Object c 133 | DeadCacodemon -> Object c 134 | DeadLostSoulInvisible -> Object c 135 | BloodyMessExplodedPlayer -> Object c 136 | BloodyMessAsAbove -> Object c 137 | PoolOfBlood -> Object c 138 | PoolOfGuts -> Object c 139 | SmallPoolOfGuts -> Object c 140 | PoolOfBrains -> Object c 141 | HangingVictimTwitching2 -> Object c 142 | HangingVictimArmsSpread -> Object c 143 | HangingVictim1Legged -> Object c 144 | HangingPairOfLegs2 -> Object c 145 | HangingLeg2-> Object c 146 | -------------------------------------------------------------------------------- /src/UI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UI where 3 | 4 | import qualified Data.Map as M 5 | import qualified Data.ByteString as BS 6 | import qualified Game.Waddle as WAD 7 | import Data.Maybe 8 | import Data.CaseInsensitive hiding (map) 9 | import Control.Monad.Reader 10 | 11 | import Game 12 | 13 | uiTest :: Game RenderData 14 | uiTest = do 15 | wad' <- asks wad 16 | palette' <- asks palette 17 | 18 | let lump = fromMaybe (error "UI not found") 19 | (M.lookup (mk "STBAR") (WAD.wadLumpLookup wad')) 20 | return undefined 21 | -------------------------------------------------------------------------------- /src/Window.hs: -------------------------------------------------------------------------------- 1 | module Window(initGL) where 2 | import Graphics.UI.GLFW 3 | import Prelude hiding (init) 4 | import Control.Monad 5 | import Data.Maybe 6 | 7 | type KeyEvent = Key -> IO () 8 | 9 | type MainLoop = (Window -> IO ()) -> IO () 10 | 11 | initGL :: String -> Int -> Int -> IO MainLoop 12 | initGL windowTitle width height = do 13 | setErrorCallback (Just simpleErrorCallback) 14 | r <- init -- from GLFW 15 | unless r $ error "Error initializing GLFW!" 16 | 17 | -- Pass in some hints to GLFW to create a core OpenGL profile 18 | windowHint $ WindowHint'ClientAPI ClientAPI'OpenGL 19 | windowHint $ WindowHint'OpenGLForwardCompat True 20 | windowHint $ WindowHint'OpenGLProfile OpenGLProfile'Core 21 | windowHint $ WindowHint'ContextVersionMajor 3 22 | windowHint $ WindowHint'ContextVersionMinor 2 23 | 24 | -- Create a window, and store the context 25 | m <- createWindow width height windowTitle Nothing Nothing 26 | let w = fromMaybe (error "Couldn't create window") m 27 | 28 | setWindowPos w 0 0 29 | makeContextCurrent m 30 | 31 | -- Return a function which should be used when the window is updated 32 | return (updateWindow w) 33 | 34 | updateWindow :: Window -> MainLoop 35 | updateWindow w io 36 | = windowShouldClose w >>= \q -> 37 | if q 38 | then terminate 39 | else do 40 | io w 41 | swapBuffers w 42 | pollEvents 43 | updateWindow w io 44 | 45 | simpleErrorCallback :: (Show a, Show b) => a -> b -> IO () 46 | simpleErrorCallback e s 47 | = putStrLn $ unwords [show e, show s] 48 | --------------------------------------------------------------------------------