From e5857e84351d4cd91af2d6927e5c2f4cc5a8ecec Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 16 Apr 2014 21:21:08 +0200 Subject: [PATCH 01/20] changed massively in Types of IQM-Loader - massive Type-Change internally - VertexArrays are now read headerwise - IQM needs postprocessing for allocating C-Arrays of the Vertex-Objects as they cannot be guaranteed to be collected in the first pass of reading. (Normally they are sorted linear - but the offsets WOULD allow for them to be anywhere in-between the sections) --- src/Importer/IQM/Parser.hs | 30 ++++++- src/Importer/IQM/Types.hs | 168 +++++++++++++++++++++++++++++-------- src/Map/StaticMaps.hs | 4 +- 3 files changed, 162 insertions(+), 40 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index cd777c0..9fe8bfd 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -30,7 +30,7 @@ parseNum = (foldl1 w8ToInt) . map fromIntegral -- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad -- -- begins with _ to defeat ghc-warnings. Rename if used! -_int16 :: CParser Int16 +_int16 :: CParser Word16 _int16 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 @@ -40,7 +40,7 @@ _int16 = do return ret -- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad -int32 :: CParser Int32 +int32 :: CParser Word32 int32 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 @@ -55,6 +55,7 @@ int32 = do readHeader :: CParser IQMHeader readHeader = do _ <- lift $ string (pack "INTERQUAKEMODEL\0") + modify (+16) v <- int32 -- when v /= 2 then --TODO: error something size' <- int32 @@ -85,7 +86,7 @@ readHeader = do ofs_extensions' <- int32 return IQMHeader { version = v , filesize = size' - , flags = flags' + , flags = fromIntegral flags' , num_text = num_text' , ofs_text = ofs_text' , num_meshes = num_meshes' @@ -140,6 +141,26 @@ readMeshes n = do ms <- readMeshes (n-1) return $ m:ms +-- | Parser for Mesh-Structure +readVAF :: CParser IQMVertexArray +readVAF = do + vat <- rawEnumToVAT =<< int32 + flags' <- int32 + format <- rawEnumToVAF =<< int32 + size <- int32 + offset <- int32 + return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset + +-- | helper to read n consecutive Meshes tail-recursive +readVAFs :: Int -> CParser [IQMVertexArray] +readVAFs 1 = do + f <- readVAF + return [f] +readVAFs n = do + f <- readVAF + fs <- readVAFs (n-1) + return $ f:fs + -- | helper-Notation for subtracting 2 integral values of different kind in the precision -- of the target-kind (.-) :: forall a a1 a2. @@ -171,9 +192,12 @@ parseIQM = do modify . (+) . fromIntegral $ num_text h --put offset forward skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes + skipToCounter $ ofs_vertexarrays h --skip 0-n byots to get to vertexarray definition + va <- readVAFs (fromIntegral (num_vertexarrays h)) --read them return IQM { header = h , texts = filter (not.null) (split (unsafeCoerce '\0') text) , meshes = meshes' + , vertexArrays = va } diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 1054767..ff7eb44 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -2,18 +2,26 @@ -- 4-Byte in the documentation indicates Int32 - but not specified! module Importer.IQM.Types where +import Control.Monad.Trans.State.Lazy (StateT) import Data.Int +import Data.Word import Data.ByteString import Data.Attoparsec.ByteString.Char8 -import Control.Monad.Trans.State.Lazy (StateT) +import Foreign.Ptr +import Graphics.Rendering.OpenGL.Raw.Types +import Prelude as P -- | Mesh-Indices to distinguish the meshes referenced -newtype Mesh = Mesh Int32 deriving (Show, Eq) +newtype Mesh = Mesh Word32 deriving (Show, Eq) -- | State-Wrapped Parser-Monad which is capable of counting the -- Bytes read for offset-gap reasons type CParser a = StateT Int64 Parser a - +type Flags = GLbitfield -- ^ Alias for UInt32 +type Offset = Word32 -- ^ Alias for UInt32 +type Index = GLuint -- ^ Alias for UInt32 +type NumComponents = GLsizei -- ^ Alias for UInt32 +type IQMData = Ptr IQMVertexArrayFormat -- | Header of IQM-Format. -- @@ -23,33 +31,33 @@ type CParser a = StateT Int64 Parser a -- -- ofs_* fields are aligned at 4-byte-boundaries data IQMHeader = IQMHeader - { version :: Int32 -- ^ Must be 2 - , filesize :: Int32 - , flags :: Int32 - , num_text :: Int32 - , ofs_text :: Int32 - , num_meshes :: Int32 - , ofs_meshes :: Int32 - , num_vertexarrays :: Int32 - , num_vertexes :: Int32 - , ofs_vertexarrays :: Int32 - , num_triangles :: Int32 - , ofs_triangles :: Int32 - , ofs_adjacency :: Int32 - , num_joints :: Int32 - , ofs_joints :: Int32 - , num_poses :: Int32 - , ofs_poses :: Int32 - , num_anims :: Int32 - , ofs_anims :: Int32 - , num_frames :: Int32 - , num_framechannels :: Int32 - , ofs_frames :: Int32 - , ofs_bounds :: Int32 - , num_comment :: Int32 - , ofs_comment :: Int32 - , num_extensions :: Int32 -- ^ stored as linked list, not as array. - , ofs_extensions :: Int32 + { version :: Word32 -- ^ Must be 2 + , filesize :: Word32 + , flags :: Flags + , num_text :: Word32 + , ofs_text :: Offset + , num_meshes :: Word32 + , ofs_meshes :: Offset + , num_vertexarrays :: Word32 + , num_vertexes :: Word32 + , ofs_vertexarrays :: Offset + , num_triangles :: Word32 + , ofs_triangles :: Offset + , ofs_adjacency :: Offset + , num_joints :: Word32 + , ofs_joints :: Offset + , num_poses :: Word32 + , ofs_poses :: Offset + , num_anims :: Word32 + , ofs_anims :: Offset + , num_frames :: Word32 + , num_framechannels :: Word32 + , ofs_frames :: Offset + , ofs_bounds :: Offset + , num_comment :: Word32 + , ofs_comment :: Offset + , num_extensions :: Word32 -- ^ stored as linked list, not as array. + , ofs_extensions :: Offset } deriving (Show, Eq) -- | Format of an IQM-Mesh Structure. @@ -57,11 +65,11 @@ data IQMHeader = IQMHeader -- Read it like a Header of the Meshes lateron in the Format data IQMMesh = IQMMesh { meshName :: Maybe Mesh - , meshMaterial :: Int32 - , meshFirstVertex :: Int32 - , meshNumVertexes :: Int32 - , meshFirstTriangle :: Int32 - , meshNumTriangles :: Int32 + , meshMaterial :: Word32 + , meshFirstVertex :: Word32 + , meshNumVertexes :: Word32 + , meshFirstTriangle :: Word32 + , meshNumTriangles :: Word32 } deriving (Show, Eq) -- | Format of a whole IQM-File @@ -71,5 +79,95 @@ data IQM = IQM { header :: IQMHeader , texts :: [ByteString] , meshes :: [IQMMesh] + , vertexArrays :: [IQMVertexArray] } deriving (Show, Eq) +-- | Different Vertex-Array-Types in IQM +-- +-- Custom Types have to be > 0x10 as of specification + +data IQMVertexArrayType = IQMPosition + | IQMTexCoord + | IQMNormal + | IQMTangent + | IQMBlendIndexes + | IQMBlendWeights + | IQMColor + | IQMCustomVAT Word32 + deriving (Show, Eq) + +-- | Lookup-Function for internal enum to VertexArrayFormat + +rawEnumToVAT :: Word32 -> CParser IQMVertexArrayType +rawEnumToVAT 0 = return IQMPosition +rawEnumToVAT 1 = return IQMTexCoord +rawEnumToVAT 2 = return IQMNormal +rawEnumToVAT 3 = return IQMTangent +rawEnumToVAT 4 = return IQMBlendIndexes +rawEnumToVAT 5 = return IQMBlendWeights +rawEnumToVAT 6 = return IQMColor +rawEnumToVAT a = return $ IQMCustomVAT a + +-- | Vetrex-Array-Format of the data found at offset +data IQMVertexArrayFormat = IQMbyte + | IQMubyte + | IQMshort + | IQMushort + | IQMint + | IQMuint + | IQMhalf + | IQMfloat + | IQMdouble +-- | Unknown Word32 + deriving (Show, Eq) + +-- | Lookup-Function for internal enum to VertexArrayFormat + +rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat +rawEnumToVAF 0 = return IQMbyte +rawEnumToVAF 1 = return IQMubyte +rawEnumToVAF 2 = return IQMshort +rawEnumToVAF 3 = return IQMushort +rawEnumToVAF 4 = return IQMint +rawEnumToVAF 5 = return IQMuint +rawEnumToVAF 6 = return IQMhalf +rawEnumToVAF 7 = return IQMfloat +rawEnumToVAF 8 = return IQMdouble +--rawEnumToVAF a = return $ Unknown a +rawEnumToVAF a = fail $ P.concat ["unrecognized enum(",show a,") in VertexArrayFormat"] + + +-- | A Vertex-Array-Definiton. +-- +-- The Vertex starts at Offset and has num_vertexes * NumComponents entries. +-- +-- All Vertex-Arrays seem to have the same number of components, just differ in Type, Format +-- and Flags +data IQMVertexArray = IQMVertexArray + IQMVertexArrayType + Flags + IQMVertexArrayFormat + NumComponents + Offset + deriving (Eq) +instance Show IQMVertexArray where + show (IQMVertexArray t fl fo nc off) = "IQMVertexArray (Type: " ++ (show t) ++ + ", Flags: " ++ (show fl) ++ + ", Format: " ++ (show fo) ++ + ", NumComponents: " ++ (show nc) ++ + ", Offset: " ++ (show off) ++ + ")" + +-- | A triangle out of the Vertices at the Indexed Positions +data IQMTriangle = IQMTriangle Index Index Index + deriving (Show, Eq) + + +-- | From the IQM-Format-Description: +-- +-- each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1) +-- indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array +-- and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc. +data IQMAdjacency = IQMAdjacency Index Index Index + deriving (Show, Eq) + diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs index 895fdc5..32767f7 100644 --- a/src/Map/StaticMaps.hs +++ b/src/Map/StaticMaps.hs @@ -23,12 +23,12 @@ mapCenterMountain :: PlayMap mapCenterMountain = array ((0,0),(200,200)) nodes where nodes = water ++ beach ++ grass ++ hill ++ mountain - water = [((a,b), (Full (a,b) 0.0 Ocean BNothing NoPlayer NoPath Plain [])) | a <- [0..200], b <- [0..200], (m2d (a,b)) > 95] + water = [((a,b), (Full (a,b) 0.0 Ocean BNothing NoPlayer NoPath Plain [])) | a <- [0..200], b <- [0..200], (m2d (a,b)) > 95] beach = [((a,b), (Full (a,b) (g2d a b) Beach BNothing NoPlayer NoPath Plain [])) | a <- [0..200], b <- [0..200], (m2d (a,b)) <= 95, (m2d (a,b)) > 75] grass = [((a,b), (Full (a,b) (g2d a b) Grass BNothing NoPlayer NoPath Plain [])) | a <- [0..200], b <- [0..200], (m2d (a,b)) <= 75, (m2d (a,b)) > 25] hill = [((a,b), (Full (a,b) (g2d a b) Hill BNothing NoPlayer NoPath Plain [])) | a <- [0..200], b <- [0..200], (m2d (a,b)) <= 25, (m2d (a,b)) > 10] mountain = [((a,b), (Full (a,b) (g2d a b) Mountain BNothing NoPlayer NoPath Plain [])) | a <- [0..200], b <- [0..200], (m2d (a,b)) <= 10] - + g2d :: Int -> Int -> Float g2d x y = gauss2D (fromIntegral x) (fromIntegral y) From 8e59e10b86ca5f9d5ae02a2e481194e8fa31e378 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Wed, 23 Apr 2014 12:21:32 +0200 Subject: [PATCH 02/20] will use HashMap to reference ui widgets --- Pioneers.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index 6bc84b9..f9f638a 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -45,7 +45,8 @@ executable Pioneers SDL2 >= 0.1.0, time >=1.4.0, GLUtil >= 0.7, - attoparsec >= 0.11.2 + attoparsec >= 0.11.2, + unordered-containers >= 0.2.1 other-modules: Render.Types Default-Language: Haskell2010 From a9a97f75441d3e959d95c729bedb8731fd438060 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Wed, 23 Apr 2014 13:08:18 +0200 Subject: [PATCH 03/20] started referencing ui widgets by id via hashmap, WIP, does not compile --- Pioneers.cabal | 3 +- src/UI/UIBaseData.hs | 75 ++++++++++++ src/UI/{UITypes.hs => UIClasses.hs} | 182 ++++++---------------------- src/UI/UIOperations.hs | 26 ++++ 4 files changed, 138 insertions(+), 148 deletions(-) create mode 100644 src/UI/UIBaseData.hs rename src/UI/{UITypes.hs => UIClasses.hs} (59%) create mode 100644 src/UI/UIOperations.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index f9f638a..190a349 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -46,7 +46,8 @@ executable Pioneers time >=1.4.0, GLUtil >= 0.7, attoparsec >= 0.11.2, - unordered-containers >= 0.2.1 + unordered-containers >= 0.2.1, + hashable >= 1.0.1.1 other-modules: Render.Types Default-Language: Haskell2010 diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs new file mode 100644 index 0000000..f51d534 --- /dev/null +++ b/src/UI/UIBaseData.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} + +module UI.UIBaseData where + +import Data.Hashable +import Data.List +import Foreign.C (CFloat) +import Linear.Matrix (M44) + +-- |Unit of screen/window +type ScreenUnit = Int + + +newtype UIId = Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) + +-- |The state of a clickable ui widget. +data UIButtonState = UIButtonState + { _buttonstateIsFiring :: Bool + -- ^firing if pressed but not confirmed + , _buttonstateIsFiringAlt :: Bool + -- ^firing if pressed but not confirmed (secondary mouse button) + , _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component + , _buttonstateIsDeferredAlt :: Bool + -- ^deferred if e. g. dragging but outside component (secondary mouse button) + , _buttonstateIsReady :: Bool + -- ^ready if mouse is above component + , _buttonstateIsActivated :: Bool + -- ^in activated state (e. g. toggle button) + } deriving (Eq, Show) + + +-- |Switches primary and secondary mouse actions. +-- "monad type" "widget type" "original handler" +data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show) + +-- |A 'UI.UIClasses.MouseHandler' with button behaviour. +data ButtonHandler m w = ButtonHandler + { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) } +instance Show (ButtonHandler w) where + show _ = "ButtonHandler ***" + +-- |A collection data type that may hold any usable ui element. @m@ is a monad. +data GUIAny m = GUIAnyC GUIContainer + | GUIAnyP GUIPanel + | GUIAnyB GUIButton (ButtonHandler m GUIButton) + deriving (Show) + + +-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a +-- functionality itself. +data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit + , _width :: ScreenUnit, _height :: ScreenUnit + , _children :: [UIId] + , _priority :: Int + } deriving (Show) + +-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its +-- children components. +data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) + +-- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be +-- provided by an appropriate 'MouseHanlder'. +data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit + , _widthB :: ScreenUnit, _heightB :: ScreenUnit + , _priorityB :: Int + , _buttonState :: UIButtonState + } deriving () +instance Show GUIButton where + show w = "GUIButton {_screenXB = " ++ show (_screenXB w) + ++ " _screenYB = " ++ show (_screenYB w) + ++ " _widthB = " ++ show (_widthB w) + ++ " _heightB = " ++ show (_heightB w) + ++ " _priorityB = " ++ show (_screenYB w) + ++ " _buttonState = " ++ show (_buttonState w) + ++ "}" diff --git a/src/UI/UITypes.hs b/src/UI/UIClasses.hs similarity index 59% rename from src/UI/UITypes.hs rename to src/UI/UIClasses.hs index 7a2a14c..7081044 100644 --- a/src/UI/UITypes.hs +++ b/src/UI/UIClasses.hs @@ -1,59 +1,21 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} -module UI.UITypes where +module UI.UIClasses where -import Data.List -import Foreign.C (CFloat) -import Linear.Matrix (M44) - --- |Unit of screen/window -type ScreenUnit = Int - --- |A viewport to an OpenGL scene. -data Viewport = Viewport - { _viewportXAngle :: !Double - , _viewportYAngle :: !Double - , _viewportZDist :: !Double - , _viewportFrustum :: !(M44 CFloat) - , _viewportPositionX :: !ScreenUnit -- ^x position in window - , _viewportPositionY :: !ScreenUnit -- ^y position in window - , _viewportWidth :: !ScreenUnit -- ^viewport width in window - , _viewportHeight :: !ScreenUnit -- ^viewport height in window - } deriving (Eq, Show) - -data UIButtonState = UIButtonState - { _buttonstateIsFiring :: Bool - -- ^firing if pressed but not confirmed - , _buttonstateIsFiringAlt :: Bool - -- ^firing if pressed but not confirmed (secondary mouse button) - , _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component - , _buttonstateIsDeferredAlt :: Bool - -- ^deferred if e. g. dragging but outside component (secondary mouse button) - , _buttonstateIsReady :: Bool - -- ^ready if mouse is above component - , _buttonstateIsActivated :: Bool - -- ^in activated state (e. g. toggle button) - } deriving (Eq, Show) - - -defaultUIState :: UIButtonState -defaultUIState = UIButtonState False False False False False False +import Types class GUIAnyMap w where guiAnyMap :: (w -> b) -> GUIAny -> b - toGUIAny :: w -> GUIAny - fromGUIAny :: GUIAny -> w - -class (GUIAnyMap uiw) => GUIWidget uiw where +class (GUIAnyMap uiw) => GUIWidget m uiw where -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'. -- The bounding box wholly contains all children components. - getBoundary :: uiw -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) + getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) -- |The 'getChildren' function returns all children associated with this widget. -- -- All children must be wholly inside the parent's bounding box specified by 'getBoundary'. - getChildren :: uiw -> [GUIAny] + getChildren :: uiw -> m [UIId] getChildren _ = [] -- |The function 'isInsideSelf' tests whether a point is inside the widget itself. @@ -65,34 +27,18 @@ class (GUIAnyMap uiw) => GUIWidget uiw where isInsideSelf :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget - -> Bool + -> m Bool isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg in (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) - -- |The function 'isInside' tests whether a point is inside the widget or any child. - -- A screen position may be inside the bounding box of a widget but not considered part of the component. - -- The function returns all hit widgets that have no hit children or 'Nothing' if the point neither hits any - -- component nor the parent widget itself. - isInside :: ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate - -> uiw -- ^the parent widget - -> [GUIAny] - isInside x' y' wg = - case isInsideSelf x' y' wg of -- test inside parent's bounding box - False -> [] - True -> case concat $ map (isInside x' y') (getChildren wg) of - [] -> [toGUIAny wg] - l -> l - --TODO: Priority queue? - -- |The 'getPriority' function returns the priority score of a 'GUIWidget'. -- A widget with a high score is more in the front than a low scored widget. - getPriority :: uiw -> Int + getPriority :: uiw -> m Int getPriority _ = 0 -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. -- The shorthand should be unique for each instance. - getShorthand :: uiw -> String + getShorthand :: uiw -> m String -- |A 'GUIClickable' represents a widget with a 'UIButtonState'. -- @@ -104,13 +50,13 @@ class GUIClickable w where setButtonState s = updateButtonState (\_ -> s) getButtonState :: w -> UIButtonState -class MouseHandler a w where +class MouseHandler a m w where -- |The function 'onMousePressed' is called when the primary button is pressed -- while inside a screen coordinate within the widget ('isInside'). onMousePressed :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> w -- ^widget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMousePressed _ _ wg a = return (wg, a) -- |The function 'onMouseReleased' is called when the primary button is released @@ -120,7 +66,7 @@ class MouseHandler a w where onMouseReleased :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen x coordinate -> w -- ^wdiget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMouseReleased _ _ wg a = return (wg, a) -- |The function 'onMousePressed' is called when the secondary button is pressed @@ -128,7 +74,7 @@ class MouseHandler a w where onMousePressedAlt :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> w -- ^widget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMousePressedAlt _ _ wg a = return (wg, a) -- |The function 'onMouseReleased' is called when the secondary button is released @@ -138,7 +84,7 @@ class MouseHandler a w where onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen x coordinate -> w -- ^wdiget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMouseReleasedAlt _ _ wg a = return (wg, a) -- |The function 'onMouseMove' is invoked when the mouse is moved inside the @@ -146,7 +92,7 @@ class MouseHandler a w where onMouseMove :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> w -- ^widget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMouseMove _ _ wg a = return (wg, a) -- |The function 'onMouseMove' is invoked when the mouse enters the @@ -154,7 +100,7 @@ class MouseHandler a w where onMouseEnter :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> w -- ^widget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMouseEnter _ _ wg a = return (wg, a) -- |The function 'onMouseMove' is invoked when the mouse leaves the @@ -162,20 +108,10 @@ class MouseHandler a w where onMouseLeave :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> w -- ^widget the event is invoked on - -> a -> IO (w, a) -- ^widget after the event and the altered handler + -> a -> m (w, a) -- ^widget after the event and the altered handler onMouseLeave _ _ wg a = return (wg, a) --- |Switches primary and secondary mouse actions. -data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show) -instance Functor (MouseHandlerSwitch w) where - fmap :: (h1 -> h2) -> MouseHandlerSwitch w h1 -> MouseHandlerSwitch w h2 - fmap f (MouseHandlerSwitch h) = MouseHandlerSwitch (f h) -instance Monad (MouseHandlerSwitch w) where - (>>=) :: (MouseHandlerSwitch w h1) -> (h1 -> MouseHandlerSwitch w h2) -> MouseHandlerSwitch w h2 - (MouseHandlerSwitch h) >>= f = f h - return :: h -> MouseHandlerSwitch w h - return h = MouseHandlerSwitch h -instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where +instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch w h) w where onMousePressed x y w (MouseHandlerSwitch h) = do (w', h') <- onMousePressedAlt x y w h return (w', MouseHandlerSwitch h') @@ -198,13 +134,7 @@ instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where (w', h') <- onMouseLeave x y w h return (w', MouseHandlerSwitch h') - --- !!Important: one handler can only handle one single widget!! -data ButtonHandler w = ButtonHandler - { _action :: (w -> ScreenUnit -> ScreenUnit -> IO w) } -instance Show (ButtonHandler w) where - show _ = "ButtonHandler ***" -instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where +instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. onMousePressed _ _ wg h = do return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) @@ -243,17 +173,10 @@ instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where }) wg , h) - -data GUIAny = GUIAnyC GUIContainer - | GUIAnyP GUIPanel - | GUIAnyB GUIButton (ButtonHandler GUIButton) - deriving (Show) -instance GUIAnyMap GUIAny where +instance GUIAnyMap (GUIAny m) where guiAnyMap f w = f w - toGUIAny = id - fromGUIAny = id -instance GUIWidget GUIAny where +instance GUIWidget m (GUIAny m) where getBoundary (GUIAnyC w) = getBoundary w getBoundary (GUIAnyP w) = getBoundary w getBoundary (GUIAnyB w _) = getBoundary w @@ -273,26 +196,15 @@ instance GUIWidget GUIAny where getShorthand (GUIAnyP w) = "A" ++ getShorthand w getShorthand (GUIAnyB w _) = "A" ++ getShorthand w --- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a --- functionality itself. -data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit - , _width :: ScreenUnit, _height :: ScreenUnit - , _children :: [GUIAny] - , _priority :: Int - } deriving (Show) - instance GUIAnyMap GUIContainer where guiAnyMap f (GUIAnyC c) = f c guiAnyMap _ _ = error "invalid types in guiAnyMap" - toGUIAny cnt = GUIAnyC cnt - fromGUIAny (GUIAnyC cnt) = cnt - fromGUIAny _ = error "invalid GUIAny type" -instance GUIWidget GUIContainer where - getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) - getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt) - getChildren cnt = _children cnt - getPriority cnt = _priority cnt - getShorthand _ = "CNT" +instance GUIWidget m GUIContainer where + getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) + getBoundary cnt = return (_screenX cnt, _screenY cnt, _width cnt, _height cnt) + getChildren cnt = return $ _children cnt + getPriority cnt = return $ _priority cnt + getShorthand _ = return $ "CNT" -- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its -- children components. @@ -300,10 +212,7 @@ data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) instance GUIAnyMap GUIPanel where guiAnyMap f (GUIAnyP p) = f p guiAnyMap _ _ = error "invalid types in guiAnyMap" - toGUIAny pnl = GUIAnyP pnl - fromGUIAny (GUIAnyP pnl) = pnl - fromGUIAny _ = error "invalid GUIAny type" -instance GUIWidget GUIPanel where +instance GUIWidget m GUIPanel where getBoundary pnl = case getChildren $ _panelContainer pnl of [] -> getBoundary $ _panelContainer pnl cs -> foldl1' determineSize $ map getBoundary cs @@ -316,39 +225,18 @@ instance GUIWidget GUIPanel where h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y'' in (x'', y'', w'', h'') - getChildren pnl = getChildren $ _panelContainer pnl - getPriority pnl = getPriority $ _panelContainer pnl - getShorthand _ = "PNL" - --- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be --- provided by an appropriate 'MouseHanlder'. -data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit - , _widthB :: ScreenUnit, _heightB :: ScreenUnit - , _priorityB :: Int - , _buttonState :: UIButtonState - , _buttonAction :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton) - } deriving () + getChildren pnl = return $ getChildren $ _panelContainer pnl + getPriority pnl = return $ getPriority $ _panelContainer pnl + getShorthand _ = return $ "PNL" -instance Show GUIButton where - show w = "GUIButton {_screenXB = " ++ show (_screenXB w) - ++ " _screenYB = " ++ show (_screenYB w) - ++ " _widthB = " ++ show (_widthB w) - ++ " _heightB = " ++ show (_heightB w) - ++ " _priorityB = " ++ show (_screenYB w) - ++ " _buttonState = " ++ show (_buttonState w) - ++ " _buttonAction = " ++ "***" - ++ "}" instance GUIAnyMap GUIButton where guiAnyMap f (GUIAnyB btn _) = f btn guiAnyMap _ _ = error "invalid types in guiAnyMap" - toGUIAny btn = GUIAnyB btn $ ButtonHandler $ _buttonAction btn - fromGUIAny (GUIAnyB btn _) = btn - fromGUIAny _ = error "invalid GUIAny type" instance GUIClickable GUIButton where getButtonState = _buttonState updateButtonState f btn = btn {_buttonState = f $ _buttonState btn} -instance GUIWidget GUIButton where - getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) - getChildren _ = [] - getPriority btn = _priorityB btn - getShorthand _ = "BTN" \ No newline at end of file +instance GUIWidget m GUIButton where + getBoundary btn = return (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) + getChildren _ = return [] + getPriority btn = return $ _priorityB btn + getShorthand _ = return "BTN" \ No newline at end of file diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs new file mode 100644 index 0000000..15d5dc2 --- /dev/null +++ b/src/UI/UIOperations.hs @@ -0,0 +1,26 @@ +module UI.UIOperations where + +import Data.HashMap.Strict + +import UI.UIBaseData +import UI.UIClasses + +defaultUIState :: UIButtonState +defaultUIState = UIButtonState False False False False False False + +--TODO +-- |The function 'isInside' tests whether a point is inside the widget or any child. +-- A screen position may be inside the bounding box of a widget but not considered part of the component. +-- The function returns all hit widgets that have no hit children or 'Nothing' if the point neither hits any +-- component nor the parent widget itself. +isInside :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> UIId -- ^the parent widget + -> [UIId] +isInside x' y' wg = + case isInsideSelf x' y' wg of -- test inside parent's bounding box + False -> [] + True -> case concat $ map (isInside x' y') (getChildren wg) of + [] -> [toGUIAny wg] + l -> l +--TODO: Priority queue? From f76da4b5f6152ae749031dfeaffa7ad3bd5adf64 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Thu, 24 Apr 2014 14:21:25 +0200 Subject: [PATCH 04/20] moved generation of GLMapState GLMapState now get generated inside the renderer and takes the map-data as argument GLMapState got extended by (up to now) uninitialized and unused textures. --- src/Main.hs | 23 ++----------------- src/Render/Render.hs | 54 ++++++++++++++++++++++++++------------------ src/Types.hs | 23 ++++++++++++++++++- 3 files changed, 56 insertions(+), 44 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index a361524..e00587e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -82,9 +82,7 @@ main = (Size fbWidth fbHeight) <- glGetDrawableSize window' initRendering --generate map vertices - (mapBuffer, vert) <- getMapBufferObject - (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader - overTex <- GL.genObjectName + glMap' <- initMapShader 4 =<< getMapBufferObject print window' eventQueue <- newTQueueIO :: IO (TQueue Event) putStrLn "foo" @@ -109,23 +107,6 @@ main = , _left = False , _right = False } - glMap' = GLMapState - { _shdrVertexIndex = vi - , _shdrNormalIndex = ni - , _shdrColorIndex = ci - , _shdrProjMatIndex = pri - , _shdrViewMatIndex = vii - , _shdrModelMatIndex = mi - , _shdrNormalMatIndex = nmi - , _shdrTessInnerIndex = tli - , _shdrTessOuterIndex = tlo - , _stateTessellationFactor = 4 - , _stateMap = mapBuffer - , _mapVert = vert - , _mapProgram = mapprog - , _mapTexture = mapTex - , _overviewTexture = overTex - } env = Env { _eventsChan = eventQueue , _windowObject = window' @@ -302,7 +283,7 @@ adjustWindow = do let hudtexid = state ^. gl.glHud.hudTexture - maptexid = state ^. gl.glMap.mapTexture + maptexid = state ^. gl.glMap.renderedMapTexture allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do --default to ugly pink to see if --somethings go wrong. diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 66702aa..6b3e4d3 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -50,22 +50,11 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initMapShader :: IO ( - Program -- the GLSL-Program - , AttribLocation -- color - , AttribLocation -- normal - , AttribLocation -- vertex - , UniformLocation -- ProjectionMat - , UniformLocation -- ViewMat - , UniformLocation -- ModelMat - , UniformLocation -- NormalMat - , UniformLocation -- TessLevelInner - , UniformLocation -- TessLevelOuter - , TextureObject -- Texture where to draw into - ) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat, - -- ModelMat, NormalMat, TessLevelInner, TessLevelOuter, - -- Texture where to draw into) -initMapShader = do +initMapShader :: + Int -- ^ initial Tessallation-Factor + -> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor + -> IO GLMapState +initMapShader tessFac (buf, vertDes) = do ! vertexSource <- B.readFile mapVertexShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile @@ -120,9 +109,30 @@ initMapShader = do putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)] tex <- genObjectName + overTex <- genObjectName + + texts <- genObjectNames 6 + checkError "initShader" - return (program, colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex, normalMatrixIndex, tessLevelInner, tessLevelOuter, tex) + return GLMapState + { _mapProgram = program + , _shdrColorIndex = colorIndex + , _shdrNormalIndex = normalIndex + , _shdrVertexIndex = vertexIndex + , _shdrProjMatIndex = projectionMatrixIndex + , _shdrViewMatIndex = viewMatrixIndex + , _shdrModelMatIndex = modelMatrixIndex + , _shdrNormalMatIndex = normalMatrixIndex + , _shdrTessInnerIndex = tessLevelInner + , _shdrTessOuterIndex = tessLevelOuter + , _renderedMapTexture = tex + , _stateTessellationFactor = tessFac + , _stateMap = buf + , _mapVert = vertDes + , _overviewTexture = overTex + , _mapTextures = texts + } initHud :: IO GLHud initHud = do @@ -193,13 +203,13 @@ renderOverview = do DepthAttachment Renderbuffer (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.mapTexture) + (state ^. gl.glMap.renderedMapTexture) 0 -- Render to FrameBufferObject @@ -285,13 +295,13 @@ render = do DepthAttachment Renderbuffer (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.mapTexture) + (state ^. gl.glMap.renderedMapTexture) 0 -- Render to FrameBufferObject @@ -371,7 +381,7 @@ render = do uniform (hud ^. hudTexIndex) $= Index1 (0::GLint) activeTexture $= TextureUnit 1 - textureBinding Texture2D $= Just (state ^. gl.glMap.mapTexture) + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) uniform (hud ^. hudBackIndex) $= Index1 (1::GLint) bindBuffer ArrayBuffer $= Just (hud ^. hudVBO) diff --git a/src/Types.hs b/src/Types.hs index 64e7f17..22329f8 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -74,6 +74,26 @@ data KeyboardState = KeyboardState { _arrowsPressed :: !ArrowKeyState } +-- | State in which all map-related Data is stored +-- +-- The map itself is rendered with mapProgram and the shaders given here directly +-- This does not include any objects on the map - only the map itself +-- +-- _mapTextures must contain the following Textures (in this ordering) after initialisation: +-- +-- 1. Grass +-- +-- 2. Sand +-- +-- 3. Water +-- +-- 4. Stone +-- +-- 5. Snow +-- +-- 6. Dirt (blended on grass) + + data GLMapState = GLMapState { _shdrVertexIndex :: !GL.AttribLocation , _shdrColorIndex :: !GL.AttribLocation @@ -88,8 +108,9 @@ data GLMapState = GLMapState , _stateMap :: !GL.BufferObject , _mapVert :: !GL.NumArrayIndices , _mapProgram :: !GL.Program - , _mapTexture :: !TextureObject + , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI? , _overviewTexture :: !TextureObject + , _mapTextures :: ![TextureObject] --TODO: Fix size on list? } data GLHud = GLHud From 6879201c53a4b80bffeb2453669e5ae51d5e6d6c Mon Sep 17 00:00:00 2001 From: tpajenka Date: Thu, 24 Apr 2014 23:42:05 +0200 Subject: [PATCH 05/20] worked on storing widgets in HashMap and referencing via Id incorporated Pioneers monad into ui operations !!still WIP, does not compile (TODO: UIOperations, Callbacks, Main?, Types?)!! --- src/Types.hs | 8 +++- src/UI/Callbacks.hs | 4 +- src/UI/UIBaseData.hs | 40 +++++++++---------- src/UI/UIClasses.hs | 91 +++++++++++++++++++++++------------------- src/UI/UIOperations.hs | 2 +- 5 files changed, 79 insertions(+), 66 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 3c0ea54..a251151 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -5,12 +5,14 @@ import Control.Concurrent.STM (TQueue) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) +import qualified Data.HashMap.Strict as Map import Data.Time (UTCTime) import Linear.Matrix (M44) import Control.Monad.RWS.Strict (RWST) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types +import UI.UIBaseData --Static Read-Only-State @@ -112,6 +114,7 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool + , _uiMap :: Map.HashMap UIId (GUIAny Pioneers) } data State = State @@ -125,6 +128,9 @@ data State = State , _ui :: !UIState } +type Pioneers = RWST Env () State IO + +-- when using TemplateHaskell order of declaration matters $(makeLenses ''State) $(makeLenses ''GLState) $(makeLenses ''GLMapState) @@ -140,5 +146,3 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) - -type Pioneers = RWST Env () State IO diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index ad7a825..1e7f23b 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -4,7 +4,9 @@ module UI.Callbacks where import Control.Monad.Trans (liftIO) import Types -import UI.UITypes +import UI.UIBaseData +import UI.UIClasses +import UI.UIOperations import qualified Graphics.Rendering.OpenGL.GL as GL import Control.Lens ((^.), (.~), (%~)) diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index f51d534..de7f78f 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -1,17 +1,15 @@ -{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module UI.UIBaseData where import Data.Hashable -import Data.List -import Foreign.C (CFloat) -import Linear.Matrix (M44) +import Data.Ix -- |Unit of screen/window type ScreenUnit = Int -newtype UIId = Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) +newtype UIId = UId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) -- |The state of a clickable ui widget. data UIButtonState = UIButtonState @@ -31,12 +29,12 @@ data UIButtonState = UIButtonState -- |Switches primary and secondary mouse actions. -- "monad type" "widget type" "original handler" -data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show) +data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show) -- |A 'UI.UIClasses.MouseHandler' with button behaviour. data ButtonHandler m w = ButtonHandler { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) } -instance Show (ButtonHandler w) where +instance Show (ButtonHandler m w) where show _ = "ButtonHandler ***" -- |A collection data type that may hold any usable ui element. @m@ is a monad. @@ -48,10 +46,10 @@ data GUIAny m = GUIAnyC GUIContainer -- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a -- functionality itself. -data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit - , _width :: ScreenUnit, _height :: ScreenUnit - , _children :: [UIId] - , _priority :: Int +data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit + , _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit + , _uiChildren :: [UIId] + , _uiPriority :: Int } deriving (Show) -- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its @@ -60,16 +58,16 @@ data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) -- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be -- provided by an appropriate 'MouseHanlder'. -data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit - , _widthB :: ScreenUnit, _heightB :: ScreenUnit - , _priorityB :: Int - , _buttonState :: UIButtonState +data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit + , _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit + , _uiPriorityB :: Int + , _uiButtonState :: UIButtonState } deriving () instance Show GUIButton where - show w = "GUIButton {_screenXB = " ++ show (_screenXB w) - ++ " _screenYB = " ++ show (_screenYB w) - ++ " _widthB = " ++ show (_widthB w) - ++ " _heightB = " ++ show (_heightB w) - ++ " _priorityB = " ++ show (_screenYB w) - ++ " _buttonState = " ++ show (_buttonState w) + show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w) + ++ " _screenYB = " ++ show (_uiScreenYB w) + ++ " _widthB = " ++ show (_uiWidthB w) + ++ " _heightB = " ++ show (_uiHeightB w) + ++ " _priorityB = " ++ show (_uiScreenYB w) + ++ " _buttonState = " ++ show (_uiButtonState w) ++ "}" diff --git a/src/UI/UIClasses.hs b/src/UI/UIClasses.hs index 7081044..09bc982 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIClasses.hs @@ -2,21 +2,30 @@ module UI.UIClasses where -import Types +import Control.Lens ((^.)) +import Control.Monad +--import Control.Monad.IO.Class -- MonadIO +import Control.Monad.RWS.Strict (get) +import Data.List +import Data.Maybe +import qualified Data.HashMap.Strict as Map -class GUIAnyMap w where - guiAnyMap :: (w -> b) -> GUIAny -> b +import qualified Types as T +import UI.UIBaseData + +class GUIAnyMap m w where + guiAnyMap :: (w -> b) -> GUIAny m -> b -class (GUIAnyMap uiw) => GUIWidget m uiw where +class (Monad m) => GUIWidget m uiw where -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'. -- The bounding box wholly contains all children components. - getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) + getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) -- |The 'getChildren' function returns all children associated with this widget. -- -- All children must be wholly inside the parent's bounding box specified by 'getBoundary'. getChildren :: uiw -> m [UIId] - getChildren _ = [] + getChildren _ = return [] -- |The function 'isInsideSelf' tests whether a point is inside the widget itself. -- A screen position may be inside the bounding box of a widget but not considered part of the @@ -28,13 +37,14 @@ class (GUIAnyMap uiw) => GUIWidget m uiw where -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget -> m Bool - isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg - in (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) + isInsideSelf x' y' wg = do + (x, y, w, h) <- getBoundary wg + return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) -- |The 'getPriority' function returns the priority score of a 'GUIWidget'. -- A widget with a high score is more in the front than a low scored widget. getPriority :: uiw -> m Int - getPriority _ = 0 + getPriority _ = return 0 -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. -- The shorthand should be unique for each instance. @@ -50,7 +60,7 @@ class GUIClickable w where setButtonState s = updateButtonState (\_ -> s) getButtonState :: w -> UIButtonState -class MouseHandler a m w where +class Monad m => MouseHandler a m w where -- |The function 'onMousePressed' is called when the primary button is pressed -- while inside a screen coordinate within the widget ('isInside'). onMousePressed :: ScreenUnit -- ^screen x coordinate @@ -111,7 +121,7 @@ class MouseHandler a m w where -> a -> m (w, a) -- ^widget after the event and the altered handler onMouseLeave _ _ wg a = return (wg, a) -instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch w h) w where +instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where onMousePressed x y w (MouseHandlerSwitch h) = do (w', h') <- onMousePressedAlt x y w h return (w', MouseHandlerSwitch h') @@ -134,9 +144,9 @@ instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch w h) w where (w', h') <- onMouseLeave x y w h return (w', MouseHandlerSwitch h') -instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where +instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. - onMousePressed _ _ wg h = do + onMousePressed _ _ wg h = return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and @@ -173,10 +183,10 @@ instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where }) wg , h) -instance GUIAnyMap (GUIAny m) where +instance (Monad m) => GUIAnyMap m (GUIAny m) where guiAnyMap f w = f w -instance GUIWidget m (GUIAny m) where +instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where getBoundary (GUIAnyC w) = getBoundary w getBoundary (GUIAnyP w) = getBoundary w getBoundary (GUIAnyB w _) = getBoundary w @@ -186,36 +196,35 @@ instance GUIWidget m (GUIAny m) where isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w isInsideSelf x y (GUIAnyB w _) = (isInsideSelf x y) w - isInside x y (GUIAnyC w) = (isInside x y) w - isInside x y (GUIAnyP w) = (isInside x y) w - isInside x y (GUIAnyB w _) = (isInside x y) w getPriority (GUIAnyC w) = getPriority w getPriority (GUIAnyP w) = getPriority w getPriority (GUIAnyB w _) = getPriority w - getShorthand (GUIAnyC w) = "A" ++ getShorthand w - getShorthand (GUIAnyP w) = "A" ++ getShorthand w - getShorthand (GUIAnyB w _) = "A" ++ getShorthand w + getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str } + getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str } + getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str } -instance GUIAnyMap GUIContainer where +instance (Monad m) => GUIAnyMap m GUIContainer where guiAnyMap f (GUIAnyC c) = f c guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance GUIWidget m GUIContainer where +instance (Monad m) => GUIWidget m GUIContainer where getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) - getBoundary cnt = return (_screenX cnt, _screenY cnt, _width cnt, _height cnt) - getChildren cnt = return $ _children cnt - getPriority cnt = return $ _priority cnt + getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt) + getChildren cnt = return $ _uiChildren cnt + getPriority cnt = return $ _uiPriority cnt getShorthand _ = return $ "CNT" --- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its --- children components. -data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) -instance GUIAnyMap GUIPanel where +instance GUIAnyMap m GUIPanel where guiAnyMap f (GUIAnyP p) = f p guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance GUIWidget m GUIPanel where - getBoundary pnl = case getChildren $ _panelContainer pnl of +instance GUIWidget T.Pioneers GUIPanel where + getBoundary pnl = do + state <- get + let hmap = state ^. T.ui . T.uiMap + case _uiChildren $ _panelContainer pnl of [] -> getBoundary $ _panelContainer pnl - cs -> foldl1' determineSize $ map getBoundary cs + cs -> do + let widgets = catMaybes $ map (flip Map.lookup hmap) cs + foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets where determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) determineSize (x, y, w, h) (x', y', w', h') = @@ -225,18 +234,18 @@ instance GUIWidget m GUIPanel where h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y'' in (x'', y'', w'', h'') - getChildren pnl = return $ getChildren $ _panelContainer pnl - getPriority pnl = return $ getPriority $ _panelContainer pnl + getChildren pnl = getChildren $ _panelContainer pnl + getPriority pnl = getPriority $ _panelContainer pnl getShorthand _ = return $ "PNL" -instance GUIAnyMap GUIButton where +instance (Monad m) => GUIAnyMap m GUIButton where guiAnyMap f (GUIAnyB btn _) = f btn guiAnyMap _ _ = error "invalid types in guiAnyMap" instance GUIClickable GUIButton where - getButtonState = _buttonState - updateButtonState f btn = btn {_buttonState = f $ _buttonState btn} -instance GUIWidget m GUIButton where - getBoundary btn = return (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) + getButtonState = _uiButtonState + updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn} +instance (Monad m) => GUIWidget m GUIButton where + getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn) getChildren _ = return [] - getPriority btn = return $ _priorityB btn + getPriority btn = return $ _uiPriorityB btn getShorthand _ = return "BTN" \ No newline at end of file diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 15d5dc2..a7b95a7 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -1,6 +1,6 @@ module UI.UIOperations where -import Data.HashMap.Strict +import qualified Data.HashMap.Strict as Map import UI.UIBaseData import UI.UIClasses From 64d542adf37032ebf7894ddd7268d29affdd3d70 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 25 Apr 2014 21:21:19 +0200 Subject: [PATCH 06/20] more parsing ... -.- --- Pioneers.cabal | 12 +-- shaders/map/tessEval.shader | 98 +++++++++++++++++++++- src/Importer/IQM/Parser.hs | 158 +++++++++++++++++++++--------------- src/Importer/IQM/Types.hs | 98 +++++++++++----------- src/Main.hs | 17 ++-- 5 files changed, 256 insertions(+), 127 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index 0c2be9b..916f8bd 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,14 +16,15 @@ executable Pioneers Map.Graphics, Map.Creation, Map.StaticMaps, - IQM.Types, - IQM.TestMain, - IQM.Parser, + Importer.IQM.Types, + Importer.IQM.TestMain, + Importer.IQM.Parser, Render.Misc, Render.Render, Render.RenderObject, + Render.Types, UI.Callbacks, - Types, + UI.Types, UI.SurfaceOverlay Types main-is: Main.hs @@ -45,6 +46,7 @@ executable Pioneers SDL2 >= 0.1.0, time >=1.4.0, GLUtil >= 0.7, - attoparsec >= 0.11.2 + attoparsec >= 0.11.2, + attoparsec-binary >= 0.1 Default-Language: Haskell2010 diff --git a/shaders/map/tessEval.shader b/shaders/map/tessEval.shader index 09f6483..35afc5d 100644 --- a/shaders/map/tessEval.shader +++ b/shaders/map/tessEval.shader @@ -2,6 +2,101 @@ #extension GL_ARB_tessellation_shader : require +//#include "shaders/3rdParty/noise.glsl" + +vec3 mod289(vec3 x) { + return x - floor(x * (1.0 / 289.0)) * 289.0; +} + +vec4 mod289(vec4 x) { + return x - floor(x * (1.0 / 289.0)) * 289.0; +} + +vec4 permute(vec4 x) { + return mod289(((x*34.0)+1.0)*x); +} + +vec4 taylorInvSqrt(vec4 r) +{ + return 1.79284291400159 - 0.85373472095314 * r; +} + +float snoise(vec3 v) + { + const vec2 C = vec2(1.0/6.0, 1.0/3.0) ; + const vec4 D = vec4(0.0, 0.5, 1.0, 2.0); + +// First corner + vec3 i = floor(v + dot(v, C.yyy) ); + vec3 x0 = v - i + dot(i, C.xxx) ; + +// Other corners + vec3 g = step(x0.yzx, x0.xyz); + vec3 l = 1.0 - g; + vec3 i1 = min( g.xyz, l.zxy ); + vec3 i2 = max( g.xyz, l.zxy ); + + // x0 = x0 - 0.0 + 0.0 * C.xxx; + // x1 = x0 - i1 + 1.0 * C.xxx; + // x2 = x0 - i2 + 2.0 * C.xxx; + // x3 = x0 - 1.0 + 3.0 * C.xxx; + vec3 x1 = x0 - i1 + C.xxx; + vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y + vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y + +// Permutations + i = mod289(i); + vec4 p = permute( permute( permute( + i.z + vec4(0.0, i1.z, i2.z, 1.0 )) + + i.y + vec4(0.0, i1.y, i2.y, 1.0 )) + + i.x + vec4(0.0, i1.x, i2.x, 1.0 )); + +// Gradients: 7x7 points over a square, mapped onto an octahedron. +// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294) + float n_ = 0.142857142857; // 1.0/7.0 + vec3 ns = n_ * D.wyz - D.xzx; + + vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7) + + vec4 x_ = floor(j * ns.z); + vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N) + + vec4 x = x_ *ns.x + ns.yyyy; + vec4 y = y_ *ns.x + ns.yyyy; + vec4 h = 1.0 - abs(x) - abs(y); + + vec4 b0 = vec4( x.xy, y.xy ); + vec4 b1 = vec4( x.zw, y.zw ); + + //vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0; + //vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0; + vec4 s0 = floor(b0)*2.0 + 1.0; + vec4 s1 = floor(b1)*2.0 + 1.0; + vec4 sh = -step(h, vec4(0.0)); + + vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ; + vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ; + + vec3 p0 = vec3(a0.xy,h.x); + vec3 p1 = vec3(a0.zw,h.y); + vec3 p2 = vec3(a1.xy,h.z); + vec3 p3 = vec3(a1.zw,h.w); + +//Normalise gradients + vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3))); + p0 *= norm.x; + p1 *= norm.y; + p2 *= norm.z; + p3 *= norm.w; + +// Mix final noise value + vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0); + m = m * m; + return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1), + dot(p2,x2), dot(p3,x3) ) ); + } + + layout(triangles, equal_spacing, cw) in; in vec3 tcPosition[]; in vec4 tcColor[]; @@ -37,6 +132,7 @@ void main() float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal)); float standout = i0+i1+i2; tePosition = tePosition+tessNormal*standout; + tePosition = tePosition+0.05*snoise(tePosition); gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1); //COLOR-BLENDING @@ -48,4 +144,4 @@ void main() //mix gravel based on incline (sin (normal,up)) gmix = length(cross(tessNormal, vec3(0,1,0))); -} \ No newline at end of file +} diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 9fe8bfd..278ba76 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -8,8 +8,11 @@ module Importer.IQM.Parser (parseIQM) where import Importer.IQM.Types import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString +import Data.Attoparsec.Binary +import Data.Attoparsec (parse, takeByteString) import Data.ByteString.Char8 (pack) -import Data.ByteString (split, null) +import Data.ByteString (split, null, ByteString) +import qualified Data.ByteString as B import Data.Word import Data.Int import Unsafe.Coerce @@ -20,12 +23,12 @@ import Control.Monad import Prelude as P hiding (take, null) -- | helper-function for creating an integral out of [8-Bit Ints] -w8ToInt :: Integral a => a -> a -> a -w8ToInt i add = 256*i + add +_w8ToInt :: Integral a => a -> a -> a +_w8ToInt i add = 256*i + add -- | shorthand-function for parsing Word8 into Integrals -parseNum :: (Integral a, Integral b) => [a] -> b -parseNum = (foldl1 w8ToInt) . map fromIntegral +_parseNum :: (Integral a, Integral b) => [a] -> b +_parseNum = foldl1 _w8ToInt . map fromIntegral -- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad -- @@ -35,55 +38,62 @@ _int16 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8 - return $ parseNum [b,a] + return $ _parseNum [b,a] modify (+2) return ret -- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad -int32 :: CParser Word32 -int32 = do +_int32 :: CParser Int32 +_int32 = do ret <- lift $ do a <- anyWord8 :: Parser Word8 b <- anyWord8 :: Parser Word8 c <- anyWord8 :: Parser Word8 d <- anyWord8 :: Parser Word8 - return $ parseNum [d,c,b,a] + return $ _parseNum [d,c,b,a] modify (+4) - return $ ret + return ret + +w32leCParser :: CParser Word32 +w32leCParser = do + ret <- lift anyWord32le + modify (+4) + return ret -- | Parser for the header readHeader :: CParser IQMHeader readHeader = do _ <- lift $ string (pack "INTERQUAKEMODEL\0") modify (+16) - v <- int32 - -- when v /= 2 then --TODO: error something - size' <- int32 - flags' <- int32 - num_text' <- int32 - ofs_text' <- int32 - num_meshes' <- int32 - ofs_meshes' <- int32 - num_vertexarrays' <- int32 - num_vertexes' <- int32 - ofs_vertexarrays' <- int32 - num_triangles' <- int32 - ofs_triangles' <- int32 - ofs_adjacency' <- int32 - num_joints' <- int32 - ofs_joints' <- int32 - num_poses' <- int32 - ofs_poses' <- int32 - num_anims' <- int32 - ofs_anims' <- int32 - num_frames' <- int32 - num_framechannels' <- int32 - ofs_frames' <- int32 - ofs_bounds' <- int32 - num_comment' <- int32 - ofs_comment' <- int32 - num_extensions' <- int32 - ofs_extensions' <- int32 + v <- w32leCParser + lift $ when (v /= 2) $ fail "Version /= 2.\nThis Parser only supports Version 2 of the InterQuake-Model IQM" + -- when v /= 2 then fail parsing. + size' <- w32leCParser + flags' <- w32leCParser + num_text' <- w32leCParser + ofs_text' <- w32leCParser + num_meshes' <- w32leCParser + ofs_meshes' <- w32leCParser + num_vertexarrays' <- w32leCParser + num_vertexes' <- w32leCParser + ofs_vertexarrays' <- w32leCParser + num_triangles' <- w32leCParser + ofs_triangles' <- w32leCParser + ofs_adjacency' <- w32leCParser + num_joints' <- w32leCParser + ofs_joints' <- w32leCParser + num_poses' <- w32leCParser + ofs_poses' <- w32leCParser + num_anims' <- w32leCParser + ofs_anims' <- w32leCParser + num_frames' <- w32leCParser + num_framechannels' <- w32leCParser + ofs_frames' <- w32leCParser + ofs_bounds' <- w32leCParser + num_comment' <- w32leCParser + ofs_comment' <- w32leCParser + num_extensions' <- w32leCParser + ofs_extensions' <- w32leCParser return IQMHeader { version = v , filesize = size' , flags = fromIntegral flags' @@ -116,12 +126,12 @@ readHeader = do -- | Parser for Mesh-Structure readMesh :: CParser IQMMesh readMesh = do - name <- int32 - mat <- int32 - fv <- int32 - nv <- int32 - ft <- int32 - nt <- int32 + name <- w32leCParser + mat <- w32leCParser + fv <- w32leCParser + nv <- w32leCParser + ft <- w32leCParser + nt <- w32leCParser return IQMMesh { meshName = if name == 0 then Nothing else Just (Mesh name) , meshMaterial = mat @@ -144,11 +154,11 @@ readMeshes n = do -- | Parser for Mesh-Structure readVAF :: CParser IQMVertexArray readVAF = do - vat <- rawEnumToVAT =<< int32 - flags' <- int32 - format <- rawEnumToVAF =<< int32 - size <- int32 - offset <- int32 + vat <- rawEnumToVAT =<< w32leCParser + flags' <- w32leCParser + format <- rawEnumToVAF =<< w32leCParser + size <- w32leCParser + offset <- w32leCParser return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset -- | helper to read n consecutive Meshes tail-recursive @@ -166,7 +176,7 @@ readVAFs n = do (.-) :: forall a a1 a2. (Num a, Integral a2, Integral a1) => a1 -> a2 -> a -(.-) a b = (fromIntegral a) - (fromIntegral b) +(.-) a b = fromIntegral a - fromIntegral b infix 5 .- @@ -183,21 +193,35 @@ skipToCounter a = do put d -- | Parses an IQM-File and handles back the Haskell-Structure -parseIQM :: CParser IQM -parseIQM = do - put 0 --start at offset 0 - h <- readHeader --read header - skipToCounter $ ofs_text h --skip 0-n bytes to get to text - text <- lift . take . fromIntegral $ num_text h --read texts - modify . (+) . fromIntegral $ num_text h --put offset forward - skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes - meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes - skipToCounter $ ofs_vertexarrays h --skip 0-n byots to get to vertexarray definition - va <- readVAFs (fromIntegral (num_vertexarrays h)) --read them - return IQM - { header = h - , texts = filter (not.null) (split (unsafeCoerce '\0') text) - , meshes = meshes' - , vertexArrays = va - } +parseIQM :: String -> IO IQM +parseIQM a = + do + f <- B.readFile a + Done _ raw <- return $ parse doIQMparse f + + let ret = raw + return ret +doIQMparse :: Parser IQM +doIQMparse = + flip evalStateT 0 $ --evaluate parser with state starting at 0 + do + h <- readHeader --read header + skipToCounter $ ofs_text h --skip 0-n bytes to get to text + text <- lift . take . fromIntegral $ num_text h --read texts + modify . (+) . fromIntegral $ num_text h --put offset forward + skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes + meshes' <- readMeshes $ fromIntegral $ num_meshes h --read meshes + skipToCounter $ ofs_vertexarrays h + vaf <- readVAFs $ fromIntegral $ num_vertexarrays h --read Vertex-Arrays + + _ <- lift takeByteString + return IQM + { header = h + , texts = filter (not.null) (split (unsafeCoerce '\0') text) + , meshes = meshes' + , vertexArrays = vaf + } + +skipDrop :: Int -> Int -> ByteString -> ByteString +skipDrop a b= B.drop b . B.take a diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index ff7eb44..cc7e940 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -1,5 +1,6 @@ --- | Int32 or Int64 - depending on implementation. Format just specifies "uint". --- 4-Byte in the documentation indicates Int32 - but not specified! +{-# LANGUAGE BangPatterns #-} +-- | Word32 or Word64 - depending on implementation. Format just specifies "uint". +-- 4-Byte in the documentation indicates Word32 - but not specified! module Importer.IQM.Types where import Control.Monad.Trans.State.Lazy (StateT) @@ -31,33 +32,33 @@ type IQMData = Ptr IQMVertexArrayFormat -- -- ofs_* fields are aligned at 4-byte-boundaries data IQMHeader = IQMHeader - { version :: Word32 -- ^ Must be 2 - , filesize :: Word32 - , flags :: Flags - , num_text :: Word32 - , ofs_text :: Offset - , num_meshes :: Word32 - , ofs_meshes :: Offset - , num_vertexarrays :: Word32 - , num_vertexes :: Word32 - , ofs_vertexarrays :: Offset - , num_triangles :: Word32 - , ofs_triangles :: Offset - , ofs_adjacency :: Offset - , num_joints :: Word32 - , ofs_joints :: Offset - , num_poses :: Word32 - , ofs_poses :: Offset - , num_anims :: Word32 - , ofs_anims :: Offset - , num_frames :: Word32 - , num_framechannels :: Word32 - , ofs_frames :: Offset - , ofs_bounds :: Offset - , num_comment :: Word32 - , ofs_comment :: Offset - , num_extensions :: Word32 -- ^ stored as linked list, not as array. - , ofs_extensions :: Offset + { version :: !Word32 -- ^ Must be 2 + , filesize :: !Word32 + , flags :: !Flags + , num_text :: !Word32 + , ofs_text :: !Offset + , num_meshes :: !Word32 + , ofs_meshes :: !Offset + , num_vertexarrays :: !Word32 + , num_vertexes :: !Word32 + , ofs_vertexarrays :: !Offset + , num_triangles :: !Word32 + , ofs_triangles :: !Offset + , ofs_adjacency :: !Offset + , num_joints :: !Word32 + , ofs_joints :: !Offset + , num_poses :: !Word32 + , ofs_poses :: !Offset + , num_anims :: !Word32 + , ofs_anims :: !Offset + , num_frames :: !Word32 + , num_framechannels :: !Word32 + , ofs_frames :: !Offset + , ofs_bounds :: !Offset + , num_comment :: !Word32 + , ofs_comment :: !Offset + , num_extensions :: !Word32 -- ^ stored as linked list, not as array. + , ofs_extensions :: !Offset } deriving (Show, Eq) -- | Format of an IQM-Mesh Structure. @@ -72,6 +73,22 @@ data IQMMesh = IQMMesh , meshNumTriangles :: Word32 } deriving (Show, Eq) +-- | Format of IQM-Triangle Structure +data IQMTriangle = IQMTriangle VertexIndex VertexIndex VertexIndex + +-- | Type-Alias for Word32 indicating an index on vertices in IQMMesh +type VertexIndex = Word32 + +-- | Type-Alias for Word32 indicating an index on IQMTriangle +type TriangleIndex = Word32 + +-- | From the IQM-Format-Description: +-- +-- each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1) +-- indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array +-- and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc. +data IQMAdjacency = IQMAdjacency TriangleIndex TriangleIndex TriangleIndex + -- | Format of a whole IQM-File -- -- still unfinished! @@ -151,23 +168,10 @@ data IQMVertexArray = IQMVertexArray Offset deriving (Eq) instance Show IQMVertexArray where - show (IQMVertexArray t fl fo nc off) = "IQMVertexArray (Type: " ++ (show t) ++ - ", Flags: " ++ (show fl) ++ - ", Format: " ++ (show fo) ++ - ", NumComponents: " ++ (show nc) ++ - ", Offset: " ++ (show off) ++ + show (IQMVertexArray t fl fo nc off) = "IQMVertexArray (Type: " ++ show t ++ + ", Flags: " ++ show fl ++ + ", Format: " ++ show fo ++ + ", NumComponents: " ++ show nc ++ + ", Offset: " ++ show off ++ ")" --- | A triangle out of the Vertices at the Indexed Positions -data IQMTriangle = IQMTriangle Index Index Index - deriving (Show, Eq) - - --- | From the IQM-Format-Description: --- --- each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1) --- indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array --- and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc. -data IQMAdjacency = IQMAdjacency Index Index Index - deriving (Show, Eq) - diff --git a/src/Main.hs b/src/Main.hs index 73279e8..833042b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,7 +16,6 @@ import Control.Concurrent.STM (TQueue, newTQueueIO) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) -import Control.Monad.Trans.State (evalStateT) import Data.Functor ((<$>)) import Data.Distributive (distribute, collect) import Data.Monoid (mappend) @@ -51,17 +50,21 @@ import Render.Render (initRendering, import UI.Callbacks import Types import Importer.IQM.Parser -import Data.Attoparsec.Char8 (parseTest) -import qualified Data.ByteString as B +--import Data.Attoparsec.Char8 (parseTest) +--import qualified Data.ByteString as B -- import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- -testParser :: IO () -testParser = do - f <- B.readFile "sample.iqm" - parseTest (evalStateT parseIQM 0) f +testParser :: String -> IO () +testParser a = putStrLn . show =<< parseIQM a +{-do + f <- B.readFile a + putStrLn "reading in:" + putStrLn $ show f + putStrLn "parsed:" + parseTest parseIQM f-} -------------------------------------------------------------------------------- From e6a56b84097b7a97b8da8cf4bbe5d0ca76033801 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 25 Apr 2014 23:58:20 +0200 Subject: [PATCH 07/20] more iqm - not tested, but typechecks and builds. --- src/Importer/IQM/Parser.hs | 22 +++++++++++++++++++--- src/Importer/IQM/Types.hs | 25 ++++++++++++++++++++++--- 2 files changed, 41 insertions(+), 6 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 278ba76..e332df8 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -9,9 +9,9 @@ import Importer.IQM.Types import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString import Data.Attoparsec.Binary -import Data.Attoparsec (parse, takeByteString) import Data.ByteString.Char8 (pack) import Data.ByteString (split, null, ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCString) import qualified Data.ByteString as B import Data.Word import Data.Int @@ -19,6 +19,9 @@ import Unsafe.Coerce import Control.Monad.Trans.State import Control.Monad.Trans.Class import Control.Monad +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils import Prelude as P hiding (take, null) @@ -159,7 +162,7 @@ readVAF = do format <- rawEnumToVAF =<< w32leCParser size <- w32leCParser offset <- w32leCParser - return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset + return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset nullPtr -- | helper to read n consecutive Meshes tail-recursive readVAFs :: Int -> CParser [IQMVertexArray] @@ -198,10 +201,23 @@ parseIQM a = do f <- B.readFile a Done _ raw <- return $ parse doIQMparse f - + let ret = raw return ret +readInVAO :: IQMVertexArray -> ByteString -> IO IQMVertexArray +readInVAO (IQMVertexArray type' a format num offset ptr) d = + do + let + byteLen = (fromIntegral num)*(vaSize format) + data' = skipDrop (fromIntegral offset) byteLen d + + when (not (ptr == nullPtr)) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type' + p <- mallocBytes byteLen + unsafeUseAsCString data' (\s -> copyBytes p s byteLen) + p' <- unsafeCoerce p + return (IQMVertexArray type' a format num offset p') + doIQMparse :: Parser IQM doIQMparse = flip evalStateT 0 $ --evaluate parser with state starting at 0 diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index cc7e940..3558660 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-} -- | Word32 or Word64 - depending on implementation. Format just specifies "uint". -- 4-Byte in the documentation indicates Word32 - but not specified! module Importer.IQM.Types where @@ -11,6 +11,9 @@ import Data.Attoparsec.ByteString.Char8 import Foreign.Ptr import Graphics.Rendering.OpenGL.Raw.Types import Prelude as P +import Foreign.Storable +import Foreign.C.Types +import Foreign.Marshal.Array -- | Mesh-Indices to distinguish the meshes referenced newtype Mesh = Mesh Word32 deriving (Show, Eq) @@ -22,7 +25,7 @@ type Flags = GLbitfield -- ^ Alias for UInt32 type Offset = Word32 -- ^ Alias for UInt32 type Index = GLuint -- ^ Alias for UInt32 type NumComponents = GLsizei -- ^ Alias for UInt32 -type IQMData = Ptr IQMVertexArrayFormat +type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data -- | Header of IQM-Format. -- @@ -138,6 +141,21 @@ data IQMVertexArrayFormat = IQMbyte -- | Unknown Word32 deriving (Show, Eq) +vaSize :: IQMVertexArrayFormat -> Int +vaSize IQMbyte = sizeOf (undefined :: CSChar) +vaSize IQMubyte = sizeOf (undefined :: CUChar) +vaSize IQMshort = sizeOf (undefined :: CShort) +vaSize IQMushort = sizeOf (undefined :: CUShort) +vaSize IQMint = sizeOf (undefined :: CInt) +vaSize IQMuint = sizeOf (undefined :: CUInt) +vaSize IQMhalf = sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype +vaSize IQMfloat = sizeOf (undefined :: CFloat) +vaSize IQMdouble = sizeOf (undefined :: CDouble) + +--mallocVArray :: Storable a => IQMVertexArrayFormat -> Int -> IO (Ptr a) +--mallocVArray IQMbyte n = mallocArray n :: IO (Ptr CSChar) +--mallocVArray IQMubyte n = mallocArray n :: IO (Ptr CUChar) + -- | Lookup-Function for internal enum to VertexArrayFormat rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat @@ -166,9 +184,10 @@ data IQMVertexArray = IQMVertexArray IQMVertexArrayFormat NumComponents Offset + IQMData deriving (Eq) instance Show IQMVertexArray where - show (IQMVertexArray t fl fo nc off) = "IQMVertexArray (Type: " ++ show t ++ + show (IQMVertexArray t fl fo nc off _) = "IQMVertexArray (Type: " ++ show t ++ ", Flags: " ++ show fl ++ ", Format: " ++ show fo ++ ", NumComponents: " ++ show nc ++ From a81418bf40e5a5b65b7fb9e597c2a5c2f2192cb3 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 00:15:36 +0200 Subject: [PATCH 08/20] iqm does not work .. :( --- src/Importer/IQM/Parser.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index e332df8..e330f19 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -200,8 +200,13 @@ parseIQM :: String -> IO IQM parseIQM a = do f <- B.readFile a - Done _ raw <- return $ parse doIQMparse f - + putStrLn "Before Parse:" + putStrLn $ show f + putStrLn "Real Parse:" + r <- return $ parse doIQMparse f + raw <- case r of + Done _ x -> return x + y -> error $ show y let ret = raw return ret @@ -228,7 +233,7 @@ doIQMparse = modify . (+) . fromIntegral $ num_text h --put offset forward skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes meshes' <- readMeshes $ fromIntegral $ num_meshes h --read meshes - skipToCounter $ ofs_vertexarrays h + skipToCounter $ ofs_vertexarrays h --skip 0-n bytes to get to Vertex-Arrays vaf <- readVAFs $ fromIntegral $ num_vertexarrays h --read Vertex-Arrays _ <- lift takeByteString From 2e22e77d7552d7e0b708dff63468ef4bd5d43d9b Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 16:52:32 +0200 Subject: [PATCH 09/20] memory gets allocated and written. No garantuee for correctness.... --- src/Importer/IQM/Parser.hs | 32 ++++++++++++++++---------------- src/Importer/IQM/Types.hs | 8 ++++---- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index e330f19..0295516 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -200,28 +200,30 @@ parseIQM :: String -> IO IQM parseIQM a = do f <- B.readFile a - putStrLn "Before Parse:" - putStrLn $ show f - putStrLn "Real Parse:" - r <- return $ parse doIQMparse f - raw <- case r of + -- Parse Headers/Offsets + let result = parse doIQMparse f + raw <- case result of Done _ x -> return x - y -> error $ show y - let ret = raw - return ret + y -> error $ show y + -- Fill Vertex-Arrays with data of Offsets + let va = vertexArrays raw + va' <- mapM (readInVAO f) va + return $ raw { + vertexArrays = va' + } -readInVAO :: IQMVertexArray -> ByteString -> IO IQMVertexArray -readInVAO (IQMVertexArray type' a format num offset ptr) d = +readInVAO :: ByteString -> IQMVertexArray -> IO IQMVertexArray +readInVAO d (IQMVertexArray type' a format num offset ptr) = do let - byteLen = (fromIntegral num)*(vaSize format) + byteLen = fromIntegral num * vaSize format data' = skipDrop (fromIntegral offset) byteLen d - when (not (ptr == nullPtr)) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type' + unless (ptr == nullPtr) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type' p <- mallocBytes byteLen + putStrLn $ concat ["Allocating ", show byteLen, " Bytes at ", show p] unsafeUseAsCString data' (\s -> copyBytes p s byteLen) - p' <- unsafeCoerce p - return (IQMVertexArray type' a format num offset p') + return $ IQMVertexArray type' a format num offset $ castPtr p doIQMparse :: Parser IQM doIQMparse = @@ -235,8 +237,6 @@ doIQMparse = meshes' <- readMeshes $ fromIntegral $ num_meshes h --read meshes skipToCounter $ ofs_vertexarrays h --skip 0-n bytes to get to Vertex-Arrays vaf <- readVAFs $ fromIntegral $ num_vertexarrays h --read Vertex-Arrays - - _ <- lift takeByteString return IQM { header = h , texts = filter (not.null) (split (unsafeCoerce '\0') text) diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 3558660..01ec020 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-} +-- {-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-} -- | Word32 or Word64 - depending on implementation. Format just specifies "uint". -- 4-Byte in the documentation indicates Word32 - but not specified! module Importer.IQM.Types where @@ -13,7 +13,6 @@ import Graphics.Rendering.OpenGL.Raw.Types import Prelude as P import Foreign.Storable import Foreign.C.Types -import Foreign.Marshal.Array -- | Mesh-Indices to distinguish the meshes referenced newtype Mesh = Mesh Word32 deriving (Show, Eq) @@ -148,7 +147,7 @@ vaSize IQMshort = sizeOf (undefined :: CShort) vaSize IQMushort = sizeOf (undefined :: CUShort) vaSize IQMint = sizeOf (undefined :: CInt) vaSize IQMuint = sizeOf (undefined :: CUInt) -vaSize IQMhalf = sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype +vaSize IQMhalf = sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype FIXME! vaSize IQMfloat = sizeOf (undefined :: CFloat) vaSize IQMdouble = sizeOf (undefined :: CDouble) @@ -187,10 +186,11 @@ data IQMVertexArray = IQMVertexArray IQMData deriving (Eq) instance Show IQMVertexArray where - show (IQMVertexArray t fl fo nc off _) = "IQMVertexArray (Type: " ++ show t ++ + show (IQMVertexArray t fl fo nc off dat) = "IQMVertexArray (Type: " ++ show t ++ ", Flags: " ++ show fl ++ ", Format: " ++ show fo ++ ", NumComponents: " ++ show nc ++ ", Offset: " ++ show off ++ + ", Data at: " ++ show dat ++ ")" From 5223c34da2f24d1f217863df33826affd757ba8c Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 17:12:19 +0200 Subject: [PATCH 10/20] 100% Haddock --- src/Importer/IQM/Parser.hs | 16 ++++++++++++++++ src/Importer/IQM/Types.hs | 13 ++++++++++--- 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 0295516..1d5b9fe 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -196,6 +196,9 @@ skipToCounter a = do put d -- | Parses an IQM-File and handles back the Haskell-Structure +-- +-- Does a 2-Pass-Parsing. Reads in Structure on first pass (O(n))and +-- fills the Structure in a 2nd Pass from Offsets (O(memcpy'd bytes)). parseIQM :: String -> IO IQM parseIQM a = do @@ -212,6 +215,11 @@ parseIQM a = vertexArrays = va' } +-- | Allocates memory for the Vertex-data and copies it over there +-- from the given input-String +-- +-- Note: The String-Operations are O(1), so only O(numberOfCopiedBytes) +-- is needed in term of computation. readInVAO :: ByteString -> IQMVertexArray -> IO IQMVertexArray readInVAO d (IQMVertexArray type' a format num offset ptr) = do @@ -225,6 +233,10 @@ readInVAO d (IQMVertexArray type' a format num offset ptr) = unsafeUseAsCString data' (\s -> copyBytes p s byteLen) return $ IQMVertexArray type' a format num offset $ castPtr p +-- | Real internal Parser. +-- +-- Consumes the String only once, thus in O(n). But all Data-Structures are +-- not allocated and copied. readInVAO has to be called on each one. doIQMparse :: Parser IQM doIQMparse = flip evalStateT 0 $ --evaluate parser with state starting at 0 @@ -244,5 +256,9 @@ doIQMparse = , vertexArrays = vaf } +-- | Helper-Function for Extracting a random substring out of a Bytestring +-- by the Offsets provided. +-- +-- O(1). skipDrop :: Int -> Int -> ByteString -> ByteString skipDrop a b= B.drop b . B.take a diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 01ec020..847320f 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -20,10 +20,19 @@ newtype Mesh = Mesh Word32 deriving (Show, Eq) -- Bytes read for offset-gap reasons type CParser a = StateT Int64 Parser a +-- | Alias type Flags = GLbitfield -- ^ Alias for UInt32 + +-- | Alias type Offset = Word32 -- ^ Alias for UInt32 + +-- | Alias type Index = GLuint -- ^ Alias for UInt32 + +-- | Alias type NumComponents = GLsizei -- ^ Alias for UInt32 + +-- | Data-BLOB inside IQM type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data -- | Header of IQM-Format. @@ -104,7 +113,6 @@ data IQM = IQM -- | Different Vertex-Array-Types in IQM -- -- Custom Types have to be > 0x10 as of specification - data IQMVertexArrayType = IQMPosition | IQMTexCoord | IQMNormal @@ -116,7 +124,6 @@ data IQMVertexArrayType = IQMPosition deriving (Show, Eq) -- | Lookup-Function for internal enum to VertexArrayFormat - rawEnumToVAT :: Word32 -> CParser IQMVertexArrayType rawEnumToVAT 0 = return IQMPosition rawEnumToVAT 1 = return IQMTexCoord @@ -140,6 +147,7 @@ data IQMVertexArrayFormat = IQMbyte -- | Unknown Word32 deriving (Show, Eq) +-- | Get the Size (in Bytes) of the given IQMVertexArrayFormat-Struct vaSize :: IQMVertexArrayFormat -> Int vaSize IQMbyte = sizeOf (undefined :: CSChar) vaSize IQMubyte = sizeOf (undefined :: CUChar) @@ -156,7 +164,6 @@ vaSize IQMdouble = sizeOf (undefined :: CDouble) --mallocVArray IQMubyte n = mallocArray n :: IO (Ptr CUChar) -- | Lookup-Function for internal enum to VertexArrayFormat - rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat rawEnumToVAF 0 = return IQMbyte rawEnumToVAF 1 = return IQMubyte From 160c6e3ae85bcbdeddc796e7ecd9bc2d80380bcc Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 17:33:17 +0200 Subject: [PATCH 11/20] rewrote readme, enhanced .gitignore --- .gitignore | 8 ++++++++ README | 4 ---- README.md | 21 +++++++++++++++++++++ 3 files changed, 29 insertions(+), 4 deletions(-) delete mode 100644 README create mode 100644 README.md diff --git a/.gitignore b/.gitignore index 925f33a..0df715f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,11 @@ /.dist-buildwrapper /.project /.settings +.cabal-sandbox +*.trace +cabal.sandbox.config +deps/hsSDL2* +deps/*.deb +dist/* +*.swp + diff --git a/README b/README deleted file mode 100644 index a831599..0000000 --- a/README +++ /dev/null @@ -1,4 +0,0 @@ -Pioneers -======== - -A Settlers II inspired game written in Haskell diff --git a/README.md b/README.md new file mode 100644 index 0000000..4832f95 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# Pioneers + +A Settlers II inspired game written in Haskell + +## Development-Status + +Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers + +## Features + +Note, that most of it is just planned and due to change. + +- modern OpenGL3.x-Engine +- themeable with different Cultures +- rock-solid Multiplayer (no desync, just slightly more lag in case of resync) + +## Why Haskell? + +- There are not enough good games written in functional languages. +- More robust and easier to reason about lateron + From 8a3597f754c15c67dddf93e56fa5683f09f3ad2b Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 17:40:08 +0200 Subject: [PATCH 12/20] moooaaar Readme --- README.md | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/README.md b/README.md index 4832f95..e80b7a2 100644 --- a/README.md +++ b/README.md @@ -6,6 +6,24 @@ A Settlers II inspired game written in Haskell Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers +## Compiling + +1. Clone this repository +2. Set up cabal-sandbox +``` +$ cabal sandbox init +$ cd deps +$ ./getDeps.sh +$ cd .. +$ cabal sandbox add-source deps/hsSDL2 +``` +3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) +4. install dependencies `cabal install --only-dependencies` +5. build `cabal build` +6. run `./Pioneers` + +Step 2 is likely to break in the future due to restructuring in hsSDL2. This will be updated accordingly then. + ## Features Note, that most of it is just planned and due to change. From 93018173f6e6ff2cd493559d460720517dea307f Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 17:42:35 +0200 Subject: [PATCH 13/20] readme --- README.md | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index e80b7a2..39048e9 100644 --- a/README.md +++ b/README.md @@ -8,19 +8,19 @@ Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers ## Compiling -1. Clone this repository -2. Set up cabal-sandbox -``` -$ cabal sandbox init -$ cd deps -$ ./getDeps.sh -$ cd .. -$ cabal sandbox add-source deps/hsSDL2 -``` -3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) -4. install dependencies `cabal install --only-dependencies` -5. build `cabal build` -6. run `./Pioneers` +1. Clone this repository +2. Set up cabal-sandbox + ``` + $ cabal sandbox init + $ cd deps + $ ./getDeps.sh + $ cd .. + $ cabal sandbox add-source deps/hsSDL2 + ``` +3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) +4. install dependencies `cabal install --only-dependencies` +5. build `cabal build` +6. run `./Pioneers` Step 2 is likely to break in the future due to restructuring in hsSDL2. This will be updated accordingly then. From bd582ac84b15fdf2db97009f3ec372214060ab12 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 17:44:41 +0200 Subject: [PATCH 14/20] even more readme.. --- README.md | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 39048e9..4563fb0 100644 --- a/README.md +++ b/README.md @@ -10,13 +10,11 @@ Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers 1. Clone this repository 2. Set up cabal-sandbox - ``` - $ cabal sandbox init - $ cd deps - $ ./getDeps.sh - $ cd .. - $ cabal sandbox add-source deps/hsSDL2 - ``` + $ cabal sandbox init + $ cd deps + $ ./getDeps.sh + $ cd .. + $ cabal sandbox add-source deps/hsSDL2 3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) 4. install dependencies `cabal install --only-dependencies` 5. build `cabal build` From 2d80c9238419a08706adedcf34352e7c52e8147d Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sat, 26 Apr 2014 19:16:53 +0200 Subject: [PATCH 15/20] finished storing ui widgets into a HashMap and referencing them by UIId. Additionally, widgets functions now use the Pioneers monad. Branch is compiling again and works. --- src/Main.hs | 3 + src/Types.hs | 1 + src/UI/Callbacks.hs | 122 ++++++++++++++++++++++++++--------------- src/UI/UIBaseData.hs | 18 +++--- src/UI/UIClasses.hs | 12 ++-- src/UI/UIOperations.hs | 83 +++++++++++++++++++++++----- 6 files changed, 166 insertions(+), 73 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index a361524..d8b23b7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -103,6 +103,7 @@ main = far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio + (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False , _down = False @@ -174,6 +175,8 @@ main = } , _ui = UIState { _uiHasChanged = True + , _uiMap = guiMap + , _uiRoots = guiRoots } } diff --git a/src/Types.hs b/src/Types.hs index a251151..451c094 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -115,6 +115,7 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool , _uiMap :: Map.HashMap UIId (GUIAny Pioneers) + , _uiRoots :: [UIId] } data State = State diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 1e7f23b..bf01360 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -2,53 +2,85 @@ module UI.Callbacks where -import Control.Monad.Trans (liftIO) + +import qualified Graphics.Rendering.OpenGL.GL as GL +import Control.Lens ((^.), (.~)) +import Control.Monad (liftM) +import Control.Monad.RWS.Strict (get, modify) +import Control.Monad.Trans (liftIO) +import qualified Data.HashMap.Strict as Map +import Data.List (foldl') +import Data.Maybe +import Foreign.Marshal.Array (pokeArray) +import Foreign.Marshal.Alloc (allocaBytes) +import Render.Misc (genColorData) + import Types import UI.UIBaseData import UI.UIClasses import UI.UIOperations -import qualified Graphics.Rendering.OpenGL.GL as GL -import Control.Lens ((^.), (.~), (%~)) -import Render.Misc (genColorData) -import Foreign.Marshal.Array (pokeArray) -import Foreign.Marshal.Alloc (allocaBytes) -import Control.Monad.RWS.Strict (get, liftIO, modify) - data Pixel = Pixel Int Int -getGUI :: [GUIAny] -getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1 - , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0 - [toGUIAny $ GUIContainer 0 80 100 200 [] 4 - ,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage - ] 3 - ] +createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId]) +createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0) + , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1) + , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3) + , (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 ) + , (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage)) + ], [UIId 0]) + +getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers] +getGUI hmap = Map.elems hmap -testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w +getRootIds :: Pioneers [UIId] +getRootIds = do + state <- get + return $ state ^. ui.uiRoots + +getRoots :: Pioneers [GUIAny Pioneers] +getRoots = do + state <- get + rootIds <- getRootIds + let hMap = state ^. ui.uiMap + return $ toGUIAnys hMap rootIds + +testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w testMessage w x y = do - putStrLn ("\tclick on " ++ show x ++ "," ++ show y) - return w + liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y) + return w -- | Handler for UI-Inputs. -- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... clickHandler :: Pixel -> Pioneers () -clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of - [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] - hit -> liftIO $ do - _ <- sequence $ map (\w -> - case w of - (GUIAnyB b h) -> do - putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) - ++ " at ["++show x++","++show y++"]" - (b', h') <- onMousePressed x y b h - _ <- onMouseReleased x y b' h' - return () - _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) - ++ " at ["++show x++","++show y++"]" - ) hit - return () +clickHandler (Pixel x y) = do + state <- get + let hMap = state ^. ui.uiMap + roots <- getRootIds + hits <- liftM concat $ mapM (getInsideId hMap x y) roots + case hits of + [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] + _ -> do + changes <- sequence $ map (\uid -> do + let w = toGUIAny hMap uid + short <- getShorthand w + bound <- getBoundary w + prio <- getPriority w + liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio + ++ " at [" ++ show x ++ "," ++ show y ++ "]" + case w of + (GUIAnyB b h) -> do + (b', h') <- onMousePressed x y b h + (b'', h'') <- onMouseReleased x y b' h' + return $ Just (uid, GUIAnyB b'' h'') + _ -> return Nothing + ) $ hits + let newMap :: Map.HashMap UIId (GUIAny Pioneers) + newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes + modify $ ui.uiMap .~ newMap + return () + -- | Handler for UI-Inputs. @@ -69,36 +101,40 @@ alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate pres prepareGUI :: Pioneers () prepareGUI = do state <- get + roots <- getRoots let tex = (state ^. gl.glHud.hudTexture) liftIO $ do -- bind texture - all later calls work on this one. GL.textureBinding GL.Texture2D GL.$= Just tex - mapM_ (copyGUI tex) getGUI + mapM_ (copyGUI tex) roots modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> GUIAny -> IO () +copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers () copyGUI tex widget = do - let (xoff, yoff, width, height) = getBoundary widget + (xoff, yoff, wWidth, wHeight) <- getBoundary widget + state <- get + let + hMap = state ^. ui.uiMap int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ... --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. color = case widget of (GUIAnyC _) -> [255,0,0,128] (GUIAnyB _ _) -> [255,255,0,255] - (GUIAnyP _) -> [128,128,128,255] + (GUIAnyP _) -> [128,128,128,128] _ -> [255,0,255,255] - allocaBytes (width*height*4) $ \ptr -> do + liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do --copy data into C-Array - pokeArray ptr (genColorData (width*height) color) + pokeArray ptr (genColorData (wWidth*wHeight) color) GL.texSubImage2D GL.Texture2D 0 (GL.TexturePosition2D (int xoff) (int yoff)) - (GL.TextureSize2D (int width) (int height)) + (GL.TextureSize2D (int wWidth) (int wHeight)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr) - mapM_ (copyGUI tex) (getChildren widget) -copyGUI _ _ = return () + nextChildrenIds <- getChildren widget + mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? +--TODO: Maybe queues are better? \ No newline at end of file diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index de7f78f..d4b3399 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -9,7 +9,7 @@ import Data.Ix type ScreenUnit = Int -newtype UIId = UId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) +newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) -- |The state of a clickable ui widget. data UIButtonState = UIButtonState @@ -35,7 +35,7 @@ data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show) data ButtonHandler m w = ButtonHandler { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) } instance Show (ButtonHandler m w) where - show _ = "ButtonHandler ***" + show _ = "ButtonHandler ***" -- |A collection data type that may hold any usable ui element. @m@ is a monad. data GUIAny m = GUIAnyC GUIContainer @@ -64,10 +64,10 @@ data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUni , _uiButtonState :: UIButtonState } deriving () instance Show GUIButton where - show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w) - ++ " _screenYB = " ++ show (_uiScreenYB w) - ++ " _widthB = " ++ show (_uiWidthB w) - ++ " _heightB = " ++ show (_uiHeightB w) - ++ " _priorityB = " ++ show (_uiScreenYB w) - ++ " _buttonState = " ++ show (_uiButtonState w) - ++ "}" + show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w) + ++ " _screenYB = " ++ show (_uiScreenYB w) + ++ " _widthB = " ++ show (_uiWidthB w) + ++ " _heightB = " ++ show (_uiHeightB w) + ++ " _priorityB = " ++ show (_uiScreenYB w) + ++ " _buttonState = " ++ show (_uiButtonState w) + ++ "}" diff --git a/src/UI/UIClasses.hs b/src/UI/UIClasses.hs index 09bc982..377e463 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIClasses.hs @@ -27,17 +27,17 @@ class (Monad m) => GUIWidget m uiw where getChildren :: uiw -> m [UIId] getChildren _ = return [] - -- |The function 'isInsideSelf' tests whether a point is inside the widget itself. + -- |The function 'isInside' tests whether a point is inside the widget itself. -- A screen position may be inside the bounding box of a widget but not considered part of the -- component. -- -- The default implementations tests if the point is within the rectangle specified by the -- 'getBoundary' function. - isInsideSelf :: ScreenUnit -- ^screen x coordinate + isInside :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget -> m Bool - isInsideSelf x' y' wg = do + isInside x' y' wg = do (x, y, w, h) <- getBoundary wg return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) @@ -193,9 +193,9 @@ instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where getChildren (GUIAnyC w) = getChildren w getChildren (GUIAnyP w) = getChildren w getChildren (GUIAnyB w _) = getChildren w - isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w - isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w - isInsideSelf x y (GUIAnyB w _) = (isInsideSelf x y) w + isInside x y (GUIAnyC w) = (isInside x y) w + isInside x y (GUIAnyP w) = (isInside x y) w + isInside x y (GUIAnyB w _) = (isInside x y) w getPriority (GUIAnyC w) = getPriority w getPriority (GUIAnyP w) = getPriority w getPriority (GUIAnyB w _) = getPriority w diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index a7b95a7..a6085d0 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -1,26 +1,79 @@ module UI.UIOperations where +import Control.Monad (liftM) import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Types import UI.UIBaseData import UI.UIClasses defaultUIState :: UIButtonState defaultUIState = UIButtonState False False False False False False ---TODO --- |The function 'isInside' tests whether a point is inside the widget or any child. --- A screen position may be inside the bounding box of a widget but not considered part of the component. --- The function returns all hit widgets that have no hit children or 'Nothing' if the point neither hits any --- component nor the parent widget itself. -isInside :: ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate - -> UIId -- ^the parent widget - -> [UIId] -isInside x' y' wg = - case isInsideSelf x' y' wg of -- test inside parent's bounding box - False -> [] - True -> case concat $ map (isInside x' y') (getChildren wg) of - [] -> [toGUIAny wg] - l -> l +toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m +toGUIAny m uid = case Map.lookup uid m of + Just w -> w + Nothing -> error "map does not contain requested key" --TODO: better error handling +{-# INLINE toGUIAny #-} + +toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m] +toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids +{-# INLINE toGUIAnys #-} +-- TODO: check for missing components? + + +-- |The function 'getInside' returns child widgets that overlap with a specific +-- screen position. +-- +-- A screen position may be inside the bounding box of a widget but not +-- considered part of the component. The function returns all hit widgets that +-- have no hit children, which may be the input widget itself, +-- or @[]@ if the point does not hit the widget. +-- +-- This function returns the widgets themselves unlike 'getInsideId'. +getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets + -> ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> GUIAny Pioneers -- ^the parent widget + -> Pioneers [GUIAny Pioneers] +getInside hMap x' y' wg = do + inside <- isInside x' y' wg + if inside -- test inside parent's bounding box + then do + childrenIds <- getChildren wg + hitChildren <- liftM concat $ mapM (getInside hMap x' y') (toGUIAnys hMap childrenIds) + case hitChildren of + [] -> return [wg] + _ -> return hitChildren + else return [] --TODO: Priority queue? + +-- |The function 'getInsideId' returns child widgets that overlap with a +-- specific screen position. +-- +-- A screen position may be inside the bounding box of a widget but not +-- considered part of the component. The function returns all hit widgets that +-- have no hit children, which may be the input widget itself, +-- or @[]@ if the point does not hit the widget. +-- +-- This function returns the 'UIId's of the widgets unlike 'getInside'. +getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets + -> ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> UIId -- ^the parent widget + -> Pioneers [UIId] +getInsideId hMap x' y' uid = do + let wg = toGUIAny hMap uid + inside <- isInside x' y' wg + if inside -- test inside parent's bounding box + then do + childrenIds <- getChildren wg + hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds + case hitChildren of + [] -> return [uid] + _ -> return hitChildren + else return [] +--TODO: Priority queue? + + From d5eb4f93a32729b704dac806d43d54cecb8de5bc Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sat, 26 Apr 2014 19:58:20 +0200 Subject: [PATCH 16/20] removed unnecessary language extension --- Pioneers.cabal | 6 +++--- src/UI/Callbacks.hs | 2 -- src/UI/UIBaseData.hs | 1 + 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index 190a349..e7901ba 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -36,6 +36,8 @@ executable Pioneers array >=0.4, random >=1.0.1, transformers >=0.3.0, + unordered-containers >= 0.2.1, + hashable >= 1.0.1.1, mtl >=2.1.2, stm >=2.4.2, vector >=0.10.9 && <0.11, @@ -45,9 +47,7 @@ executable Pioneers SDL2 >= 0.1.0, time >=1.4.0, GLUtil >= 0.7, - attoparsec >= 0.11.2, - unordered-containers >= 0.2.1, - hashable >= 1.0.1.1 + attoparsec >= 0.11.2 other-modules: Render.Types Default-Language: Haskell2010 diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index bf01360..58e2e59 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} - module UI.Callbacks where diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index d4b3399..c21008f 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- data and classes are separated into several modules to avoid cyclic dependencies with the Type module module UI.UIBaseData where From 8db4004a8ff618def3ed8f182d362c9358c15635 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 20:47:36 +0200 Subject: [PATCH 17/20] readmeeeee --- README.md | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 39048e9..ab6a5ce 100644 --- a/README.md +++ b/README.md @@ -10,13 +10,14 @@ Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers 1. Clone this repository 2. Set up cabal-sandbox - ``` - $ cabal sandbox init - $ cd deps - $ ./getDeps.sh - $ cd .. - $ cabal sandbox add-source deps/hsSDL2 - ``` + + ``` + $ cabal sandbox init + $ cd deps + $ ./getDeps.sh + $ cd .. + $ cabal sandbox add-source deps/hsSDL2 + ``` 3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) 4. install dependencies `cabal install --only-dependencies` 5. build `cabal build` From c4b5e69fcf102a9e4fb85d0ee745735c09b8d825 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 26 Apr 2014 21:33:28 +0200 Subject: [PATCH 18/20] added dependencies forgotten in readme --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 8d01d58..b3eccc4 100644 --- a/README.md +++ b/README.md @@ -16,7 +16,7 @@ Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers $ ./getDeps.sh $ cd .. $ cabal sandbox add-source deps/hsSDL2 -3. install libraries `sudo apt-get install libsdl2` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) +3. install libraries `sudo apt-get install libsdl2 libsdl2-dev libghc-llvm-dev` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04) 4. install dependencies `cabal install --only-dependencies` 5. build `cabal build` 6. run `./Pioneers` From b3c25a132694538224adbc6db68dc2f74df2ce6e Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Sun, 27 Apr 2014 22:29:20 +0200 Subject: [PATCH 19/20] Fixed Pioneers.cabal (hopefully) --- Pioneers.cabal | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index c8e8c83..4aad55e 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -11,21 +11,18 @@ executable Pioneers } else { ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm } - other-module + other-modules: Map.Types, Map.Graphics, Map.Creation, Map.StaticMaps, Importer.IQM.Types, - Importer.IQM.TestMain, Importer.IQM.Parser, Render.Misc, Render.Render, Render.RenderObject, Render.Types, UI.Callbacks, - UI.Types, - UI.SurfaceOverlay Types main-is: Main.hs build-depends: From f5f1f760cda8d82835389ada0da71cf7e83be56e Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Sun, 27 Apr 2014 23:49:15 +0200 Subject: [PATCH 20/20] Added first test suite with first test (questionable .cabal though) --- Pioneers.cabal | 31 +++++++++++++++++++++++++++++++ src/Map/Map.hs | 2 +- tests/MainTestSuite.hs | 20 ++++++++++++++++++++ 3 files changed, 52 insertions(+), 1 deletion(-) create mode 100644 tests/MainTestSuite.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index 4aad55e..633c0c5 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -12,6 +12,8 @@ executable Pioneers ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm } other-modules: + Map.Map, + Map.Combinators, Map.Types, Map.Graphics, Map.Creation, @@ -49,3 +51,32 @@ executable Pioneers attoparsec-binary >= 0.1 Default-Language: Haskell2010 +test-suite QuickCheckTests + type: exitcode-stdio-1.0 + hs-source-dirs: tests, src + main-is: MainTestSuite.hs + build-depends: base, + OpenGL >=2.9, + bytestring >=0.10, + OpenGLRaw >=1.4, + text >=0.11, + array >=0.4, + random >=1.0.1, + transformers >=0.3.0, + unordered-containers >= 0.2.1, + hashable >= 1.0.1.1, + mtl >=2.1.2, + stm >=2.4.2, + vector >=0.10.9 && <0.11, + distributive >=0.3.2, + linear >=1.3.1, + lens >=4.0, + SDL2 >= 0.1.0, + time >=1.4.0, + GLUtil >= 0.7, + attoparsec >= 0.11.2, + attoparsec-binary >= 0.1, + QuickCheck, + test-framework, + test-framework-quickcheck2 + Default-Language: Haskell2010 diff --git a/src/Map/Map.hs b/src/Map/Map.hs index e358cee..ba697c0 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -40,5 +40,5 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in remdups :: Ord a => [a] -> [a] remdups = map head . group . sort -prop_rd_idempot :: Ord a => [a] -> Bool +prop_rd_idempot :: [Int] -> Bool prop_rd_idempot xs = remdups xs == (remdups . remdups) xs diff --git a/tests/MainTestSuite.hs b/tests/MainTestSuite.hs new file mode 100644 index 0000000..9c46a05 --- /dev/null +++ b/tests/MainTestSuite.hs @@ -0,0 +1,20 @@ +module Main where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Map.Map + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ + testGroup "Map.Map" + [ + testProperty "remdups idempotency" prop_rd_idempot + ] + ] + +