From 78f91e522b760e54266735a39656b486c55ad3e8 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 29 Oct 2021 19:35:54 +0100 Subject: [PATCH] Unify config files, add capability to remember window position --- appDodge/Main.hs | 12 ++++++------ src/Dodge/Config/Data.hs | 4 ++++ src/Dodge/Event.hs | 9 +++++++++ src/LoadConfig.hs | 29 ----------------------------- src/Loop.hs | 14 ++++++-------- src/MatrixHelper.hs | 3 --- src/Music.hs | 3 ++- src/Padding.hs | 10 ++++++++-- src/Picture.hs | 11 +---------- src/PolyPic.hs | 29 ----------------------------- src/Polyhedra.hs | 11 ----------- src/Preload.hs | 5 ++--- src/Quaternion.hs | 2 ++ src/SameConstr.hs | 5 +++-- 14 files changed, 43 insertions(+), 104 deletions(-) delete mode 100644 src/LoadConfig.hs delete mode 100644 src/PolyPic.hs diff --git a/appDodge/Main.hs b/appDodge/Main.hs index f0cee26a3..81061a174 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -1,6 +1,5 @@ module Main where import Loop -import LoadConfig import Dodge.Data import Dodge.Initialisation import Dodge.Update @@ -22,24 +21,25 @@ import Data.Preload import Data.Preload.Render import Control.Lens ---import Foreign (Word32) import Control.Monad ---import System.Random ---import qualified Data.Map as M import qualified Data.IntMap as IM import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified SDL import qualified SDL.Mixer as Mix ---import qualified Control.Monad.Parallel as MP import Control.Parallel import qualified Data.Map.Strict as M main :: IO () main = do - (sizex,sizey) <- loadConfig + con <- loadDodgeConfig + let sizex = floor $ _windowX con + sizey = floor $ _windowY con + posx = _windowPosX con + posy = _windowPosY con setupLoop 20 (sizex,sizey) + (posx,posy) theCleanup (firstWorldLoad (sizex,sizey)) theUpdateStep diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 15d5dd758..b075450ce 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -15,6 +15,8 @@ data Configuration = Configuration , _resolution_factor :: Int -- ^ Higher values divide screen size, i.e. make the resolution worse , _windowX :: Float , _windowY :: Float + , _windowPosX :: Int + , _windowPosY :: Int , _rotate_to_wall :: Bool , _show_sound :: Bool , _debug_seconds_frame :: Bool @@ -41,6 +43,8 @@ defaultConfig = Configuration , _resolution_factor = 1 , _windowX = 800 , _windowY = 600 + , _windowPosX = 0 + , _windowPosY = 0 , _rotate_to_wall = True , _show_sound = False , _debug_seconds_frame = True diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 343b680df..0c2e6ae62 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -42,6 +42,7 @@ handleEvent e = case eventPayload e of MouseButtonEvent mbev -> handleMouseButtonEvent mbev MouseWheelEvent mwev -> handleMouseWheelEvent mwev WindowSizeChangedEvent sev -> handleResizeEvent sev + WindowMovedEvent mev -> handleWindowMoveEvent mev _ -> Just handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World @@ -58,6 +59,14 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of where but = mouseButtonEventButton mbev +{- | Sets window position in config. -} +handleWindowMoveEvent :: WindowMovedEventData -> World -> Maybe World +handleWindowMoveEvent mev w = Just $ w + & config . windowPosX .~ fromIntegral x + & config . windowPosY .~ fromIntegral y + where + P (V2 x y) = windowMovedEventPosition mev + {- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -} handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World handleResizeEvent sev w = Just diff --git a/src/LoadConfig.hs b/src/LoadConfig.hs deleted file mode 100644 index 40ab6e538..000000000 --- a/src/LoadConfig.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module LoadConfig where -import Data.Aeson ---import Foreign.C.Types -import GHC.Generics ---import qualified GHC.Int ---import qualified SDL ---import System.Directory - -data Configuration = Configuration - { windowxsize :: Int, - windowysize :: Int - } - deriving (Generic, Show) - -instance ToJSON Configuration where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Configuration - -loadConfig :: IO (Int, Int) -loadConfig = do - mayConfig <- decodeFileStrict "config.json" - case mayConfig of - Just config -> return (windowxsize config, windowysize config) - Nothing -> do - putStrLn "invalid config.json, loading default config" - return (800, 600) diff --git a/src/Loop.hs b/src/Loop.hs index b4cef294a..6a5d606fa 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -13,24 +13,23 @@ import Control.Concurrent import Control.Exception import Control.Monad import System.Mem ---import Foreign.C import SDL import qualified Graphics.Rendering.OpenGL as GL - -- | Create a game loop with an SDL window. setupLoop :: Int -- ^ Target seconds per frame -> (Int,Int) -- ^ The window size. + -> (Int,Int) -- ^ The window position. -> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop. -> IO world -- ^ Initial simulation state. -> (world -> IO world) -- ^ update, called once per frame. Allows for side effects such as rendering. -> (world -> Event -> Maybe world) -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop. -> IO () -setupLoop spf (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do +setupLoop spf (xSize,ySize) (xPos,yPos) paramCleanup ioStartWorld sideEffects eventFn = do initializeAll bracket - (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) + (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize xPos yPos)) destroyWindow $ \window -> bracket (glCreateContext window) @@ -79,14 +78,13 @@ applyEventIO fn mw e = case eventPayload e of -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e) _ -> return $ mw >>= flip fn e -- | Create an OpenGL SDL window configuration with a given x and y size. -winConfig :: Int -> Int -> WindowConfig -winConfig x y = defaultWindow +winConfig :: Int -> Int -> Int -> Int -> WindowConfig +winConfig x y px py = defaultWindow { windowGraphicsContext = OpenGLContext $ defaultOpenGL { glProfile = Core Normal 4 3 , glColorPrecision = V4 8 8 8 8 } + , windowPosition = Absolute (P (V2 (fromIntegral px) (fromIntegral py))) , windowInitialSize = V2 (fromIntegral x) (fromIntegral y) , windowResizable =True } - - diff --git a/src/MatrixHelper.hs b/src/MatrixHelper.hs index c180c86eb..c4e70b247 100644 --- a/src/MatrixHelper.hs +++ b/src/MatrixHelper.hs @@ -2,11 +2,9 @@ module MatrixHelper ( perspectiveMatrixb , isoMatrix ) where ---import Geometry import Geometry.Data import Linear.Matrix ---import Linear.V4 import Graphics.Rendering.OpenGL (GLfloat) perspectiveMatrixb @@ -23,7 +21,6 @@ perspectiveMatrixb rot zoom (V2 tranx trany) (V2 winx winy) (V2 viewFromx viewFr $ scaleMat (V2 (2*zoom/winx) (2*zoom/winy)) !*! rotMatr (-rot) !*! transMat (V2 (viewFromx-tranx) (viewFromy-trany)) - -- !*! perMat (zoom * 0.4) !*! perMat 0.4 !*! transMat (V2 (-viewFromx) (-viewFromy)) !*! vertScale (negate 0.005) diff --git a/src/Music.hs b/src/Music.hs index ae041273e..651899745 100644 --- a/src/Music.hs +++ b/src/Music.hs @@ -1,5 +1,6 @@ module Music - where + ( MusicData (..) + ) where import qualified SDL.Mixer as Mix import qualified Data.IntMap.Strict as IM diff --git a/src/Padding.hs b/src/Padding.hs index 84018ea2f..8b6619cd4 100644 --- a/src/Padding.hs +++ b/src/Padding.hs @@ -1,6 +1,12 @@ -{-| Basic padding and "justification" of lists. - -} +{-| Basic padding and "justification" of lists. -} module Padding + ( leftPad + , rightPad + , midPad + , midPadL + , rotU + , rotD + ) where leftPad :: Int -> a -> [a] -> [a] {-# INLINE leftPad #-} diff --git a/src/Picture.hs b/src/Picture.hs index ae7f8426d..19385988e 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -41,18 +41,9 @@ module Picture where import Geometry import Geometry.Vector3D ---import Geometry.Data import Picture.Data import Color ---import Data.List ---import Data.Bifunctor ---import qualified Data.DList as DL ---import Graphics.Rendering.OpenGL (lineWidth, ($=)) ---import Control.Lens ---import Data.Foldable ---import qualified Data.Vector.Fusion.Stream.Monadic as VS - blank :: Picture {-# INLINE blank #-} blank = [] @@ -157,7 +148,7 @@ translate x = map . overPos . translateH x translate3 :: Point3 -> Picture -> Picture {-# INLINE translate3 #-} -translate3 v = map $ overPos (+.+.+ v) +translate3 = map . overPos . (+.+.+) tranRot :: V2 Float -> Float -> Picture -> Picture {-# INLINE tranRot #-} diff --git a/src/PolyPic.hs b/src/PolyPic.hs deleted file mode 100644 index 511eb2701..000000000 --- a/src/PolyPic.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module PolyPic - where ---import Linear.V3 -import Linear.V4 -import Geometry -import Picture - -import Control.Lens - -data Vert = Vert - {_vtPos :: !(V2 Float) - ,_vtCol :: !(V4 Float) - } -makeLenses ''Vert - -type Pic2d = [Vert] - -polygon2d :: [Point2] -> Pic2d -polygon2d = map f . polyToTris - where - f p = Vert p black - -color2d :: RGBA -> Pic2d -> Pic2d -color2d = map . set vtCol - -translate2d :: Float -> Float -> Pic2d -> Pic2d -translate2d x y = map $ over vtPos (+.+ V2 x y) - diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 4688682a4..2bd2d32c3 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -11,7 +11,6 @@ module Polyhedra ) where import Geometry ---import Geometry.Data import Geometry.Vector3D import Polyhedra.Data import Picture.Data @@ -21,7 +20,6 @@ import Data.Maybe import Data.List import Data.Bifunctor import Control.Lens ---import qualified Data.Vector.Fusion.Stream.Monadic as VS translateXY :: Float -> Float -> Polyhedra -> Polyhedra translateXY x y = pyFaces %~ map (map $ first tran) @@ -31,12 +29,6 @@ translateXY x y = pyFaces %~ map (map $ first tran) rotateXY :: Float -> Polyhedra -> Polyhedra rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a --- Another representation of polyhedra is as a list of edges. --- Each edge is a tuple containing four points: the first two are the two edge --- coordinates, the last two being the normals of two planes of the polyhedra --- that the edge connects. - --, _pyEdges :: [(Point3,Point3,Point3,Point3)] - constructEdges :: [[Point3]] -> [(Point3,Point3,Point3,Point3)] constructEdges (face:faces) = mapMaybe (findReverseEdge otherEdges) (faceEdges face) ++ constructEdges faces @@ -53,7 +45,6 @@ constructEdgesList (face:faces) = concatMap (findReverseEdgeList otherEdges) (fa otherEdges = concatMap faceEdges faces constructEdgesList _ = [] - findReverseEdge :: [(Point3,Point3,Point3)] -> (Point3,Point3,Point3) @@ -130,7 +121,6 @@ polyToPics :: Polyhedra -> [Picture] polyToPics = map helpPoly3D . _pyFaces helpPoly3D :: [(Point3, Point4)] -> Picture ---{-# INLINE helpPoly3D #-} helpPoly3D vs = map f $ polyToTris vs where f (pos,col) = Verx pos col [] 0 polyNum @@ -147,6 +137,5 @@ denormalEdges (a,b,n,m) = (a,b,a - x, b - y) x = crossProd (b - a) n y = crossProd (a - b) m - polyToGeoRender :: Polyhedra -> [Point3] polyToGeoRender = concatMap (polyToTris . map fst) . _pyFaces diff --git a/src/Preload.hs b/src/Preload.hs index 540c0addf..b0b355fd4 100644 --- a/src/Preload.hs +++ b/src/Preload.hs @@ -1,14 +1,13 @@ module Preload + ( cleanUpPreload + ) where import Data.Preload import Preload.Render import Sound.Data ---import Control.Lens ---import GHC.Word (Word32) import qualified SDL.Mixer as Mix - cleanUpPreload :: PreloadData -> IO () cleanUpPreload pd = do cleanUpRenderPreload $ _renderData pd diff --git a/src/Quaternion.hs b/src/Quaternion.hs index 4b13bfef2..f99f6c51e 100644 --- a/src/Quaternion.hs +++ b/src/Quaternion.hs @@ -1,4 +1,6 @@ module Quaternion + ( rotateToZ + ) where import Geometry.Data import Geometry.Vector3D diff --git a/src/SameConstr.hs b/src/SameConstr.hs index 832537cc3..9ef637733 100644 --- a/src/SameConstr.hs +++ b/src/SameConstr.hs @@ -2,7 +2,9 @@ {- | Pulled from https://stackoverflow.com/questions/10112733/haskell-simple-constructor-comparison-function -} -module SameConstr where +module SameConstr + ( eqConstr + ) where import GHC.Generics import Data.Function (on) @@ -34,4 +36,3 @@ instance (GEqC f, GEqC g) => GEqC (f :+: g) where geqConstr (L1 x) (L1 y) = geqConstr x y geqConstr (R1 x) (R1 y) = geqConstr x y geqConstr _ _ = False -