diff --git a/appDodge/Main.hs b/appDodge/Main.hs index b6507d0fa..083eac5fe 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -24,6 +24,8 @@ import Data.Preload.Render import Control.Lens import Control.Monad +--import Control.Monad.Parallel +import qualified Data.Text as T import qualified Data.IntMap as IM import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified SDL @@ -41,13 +43,29 @@ main = do posy = _windowPosY con setupLoop 20 - (sizex,sizey) - (Just (posx,posy)) + (T.pack "Simple Game Loop") + (winConfig sizex sizey (Just (posx,posy))) theCleanup (firstWorldLoad con) theUpdateStep (flip handleEvent) +-- | Create an OpenGL SDL window configuration with a given x and y size. +winConfig :: Int -> Int -> Maybe (Int, Int) -> SDL.WindowConfig +winConfig x y winpos = SDL.defaultWindow + { SDL.windowGraphicsContext = SDL.OpenGLContext $ SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 4 3 + , SDL.glColorPrecision = SDL.V4 8 8 8 8 + } + , SDL.windowPosition = theWinPos + , SDL.windowInitialSize = SDL.V2 (fromIntegral x) (fromIntegral y) + , SDL.windowResizable = True + } + where + theWinPos = case winpos of + Just (px,py) -> SDL.Absolute (SDL.P (SDL.V2 (fromIntegral px) (fromIntegral py))) + Nothing -> SDL.Wherever + theCleanup :: Universe -> IO () theCleanup uv = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData uv) @@ -56,7 +74,6 @@ firstWorldLoad theConfig = do SDL.cursorVisible $= False theKeyConfig <- loadKeyConfig pdata <- doPreload >>= applyWorldConfig theConfig --- w <- generateWorldFromSeed 0 return $ startNewGame $ Universe {_uvWorld = initialWorld ,_config = theConfig @@ -73,7 +90,7 @@ updateRenderSplit :: Universe -> IO Universe updateRenderSplit u = do let preData = _preloadData u updateUniverse u `par` void (doDrawing (_renderData preData) u) - return $ updateUniverse u + return (updateUniverse u) playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound) playSoundUnlessRewinding u diff --git a/package.yaml b/package.yaml index ccd5bf1eb..160b8975a 100644 --- a/package.yaml +++ b/package.yaml @@ -29,13 +29,13 @@ dependencies: - OpenGL - OpenGLRaw - text -- raw-strings-qq + #- raw-strings-qq - bytestring - lens - mtl - fgl - random -- bmp + #- bmp #- monad-loops - JuicyPixels - vector @@ -83,7 +83,7 @@ executables: - -fno-liberate-case - -fno-state-hack - -funfolding-use-threshold1000 - - -funfolding-keeness-factor1000 + #- -funfolding-keeness-factor1000 - -fllvm - -optlo-O3 - -Wall diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index c84bdf6ea..098599a94 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -12,49 +12,25 @@ module Dodge.Creature.Picture , basicCrCorpse ) where import Dodge.Data ---import Dodge.Base ---import Dodge.Render.InfoBox ---import Dodge.Render.List ---import Dodge.Creature.AlertLevel.Data ---import Dodge.Picture.Layer -import Dodge.Clock import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand) import Dodge.Creature.Test import Dodge.Damage ---import Dodge.Debug.Picture import Picture import Geometry import Shape import ShapePicture import qualified Quaternion as Q ---import Geometry.Vector3D import Control.Lens -import qualified Data.IntMap.Strict as IM -import qualified Data.Vector as V -basicCrPict :: Creature - -> Configuration - -> World - -> SPic -basicCrPict cr cfig w = - drawCrEquipment cr - <> - (basicCrShape cr - , pictures $ - targetingPic ++ - [ creatureDisplayText cfig w cr - --, tr . rotdir $ _spPicture $ drawEquipment cr - ] - ) - where - targetingPic = IM.elems $ IM.mapMaybe f $ _crInv cr - f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw) + +basicCrPict :: Creature -> SPic +basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty) drawCrEquipment :: Creature -> SPic drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) -shapeAtCrPos :: Shape -> Creature -> Configuration -> World -> SPic -shapeAtCrPos sh cr _ _ = +shapeAtCrPos :: Shape -> Creature -> SPic +shapeAtCrPos sh cr = ( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh , mempty ) @@ -77,47 +53,6 @@ basicCrShape cr rotdir = rotateSH (_crDir cr) rotmdir = rotateSH (_crMvDir cr) -creatureDisplayText :: Configuration -> World -> Creature -> Picture -creatureDisplayText cfig w cr - | not (debugOn Cr_awareness cfig) = [] - | otherwise - = setLayer DebugLayer - . setDepth 20 - . translate x y - . color white - . rotate (0.5 * pi) --- . rotate (argV v - 0.5 * pi) - . scale theScale theScale - . stackText - $ clockCycle 25 (V.fromList - [ \cr' -> [crDisplayVigilance cr'] - , \cr' -> [crDisplayAwareness cr'] - ] - ) w cr - where - campos = _cameraViewFrom w - theScale = 0.15 / _cameraZoom w - cpos = _crPos cr - v = cpos -.- campos - (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v - -crDisplayAwareness :: Creature -> String -crDisplayAwareness cr - | isSuspicious = "?" - | isCognizant = "!" - | otherwise = "." - where - imAwarenesses = _cpAwareness (_crPerception cr) - isSuspicious = any f imAwarenesses && not (null imAwarenesses) - isCognizant = any g imAwarenesses && not (null imAwarenesses) - f (Suspicious _) = True - f _ = False - g (Cognizant _) = True - g _ = False - -crDisplayVigilance :: Creature -> String -crDisplayVigilance = show . _cpVigilance . _crPerception - --damageMod :: Creature -> Picture -> Picture --damageMod cr pic = piercingMod $ bluntScale pic -- where @@ -285,13 +220,13 @@ drawEquipment cr = foldMap f (_crInv cr) circLine :: Float -> Picture circLine x = line [V2 0 0,V2 x 0] -picAtCrPos :: Picture -> Creature -> Configuration -> World -> SPic +picAtCrPos :: Picture -> Creature -> SPic --{-# INLINE picAtCrPos #-} -picAtCrPos thePic cr _ _ = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic +picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic -picAtCrPosNoRot :: Picture -> Creature -> Configuration -> World -> SPic +picAtCrPosNoRot :: Picture -> Creature -> SPic --{-# INLINE picAtCrPos #-} -picAtCrPosNoRot thePic cr _ _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic +picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic basicCrCorpse :: Creature -> Corpse -> SPic basicCrCorpse cr cp = noPic . tr . scaleSH (V3 crsize crsize crsize) $ mconcat diff --git a/src/Dodge/Creature/Picture/Awareness.hs b/src/Dodge/Creature/Picture/Awareness.hs new file mode 100644 index 000000000..23c19df4f --- /dev/null +++ b/src/Dodge/Creature/Picture/Awareness.hs @@ -0,0 +1,45 @@ +module Dodge.Creature.Picture.Awareness where +import Dodge.Data +import Dodge.Clock +import Picture +import Geometry + +import qualified Data.Vector as V + +creatureDisplayText :: World -> Creature -> Picture +creatureDisplayText w cr = setLayer DebugLayer + . setDepth 20 + . translate x y + . color white + . rotate (0.5 * pi) +-- . rotate (argV v - 0.5 * pi) + . scale theScale theScale + . stackText + $ clockCycle 25 (V.fromList + [ \cr' -> [crDisplayVigilance cr'] + , \cr' -> [crDisplayAwareness cr'] + ] + ) w cr + where + campos = _cameraViewFrom w + theScale = 0.15 / _cameraZoom w + cpos = _crPos cr + v = cpos -.- campos + (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v + +crDisplayAwareness :: Creature -> String +crDisplayAwareness cr + | isSuspicious = "?" + | isCognizant = "!" + | otherwise = "." + where + imAwarenesses = _cpAwareness (_crPerception cr) + isSuspicious = any f imAwarenesses && not (null imAwarenesses) + isCognizant = any g imAwarenesses && not (null imAwarenesses) + f (Suspicious _) = True + f _ = False + g (Cognizant _) = True + g _ = False + +crDisplayVigilance :: Creature -> String +crDisplayVigilance = show . _cpVigilance . _crPerception diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index ee3970db0..c957dd2ec 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -346,7 +346,8 @@ data Creature = Creature , _crMvDir :: Float , _crTwist :: Float , _crID :: Int - , _crPict :: Creature -> Configuration -> World -> SPic + --, _crPict :: Creature -> Configuration -> World -> SPic + , _crPict :: Creature -> SPic , _crSkin :: CreatureSkin , _crUpdate :: Creature -> World -> World , _crRad :: Float diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index a73820f52..876376190 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/src/Dodge/Placement/Instance/Turret.hs @@ -75,7 +75,7 @@ updateTurret rotSpeed mc w & crOldPos .~ mcpos & crRad .~ 1 & crDir .~ mcdir - & crPict .~ (\cr _ _ -> drawCrEquipment cr) + & crPict .~ drawCrEquipment & crUpdate .~ stateUpdate followThenClearImpulses & crStance . posture .~ Aiming & crApplyDamage .~ applyNoDamage diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 6e27dffd4..dd4f47d29 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -47,17 +47,15 @@ doDrawing pdata u = do -- bind as much data into vbos as feasible at this point -- count mutable vectors setup layerCounts <- UMV.replicate (numLayers*6) 0 --- shapeCounts <- UMV.replicate 3 0 - wlwiflCounts <- UMV.replicate 3 0 -- attempt to poke in parallel let (ws,wp) = wallSPics <> worldSPic cfig w - (nShapeVs, nIndices, nSilIndices) <- MP.bindM3 (\ _ _ counts -> return counts) + ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) ) + <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts)) ( pokeBindFoldableLayer shadV layerCounts wp) ( pokeWallsWindowsFloor (shadVBOptr $ _wallTextureShader pdata) (shadVBOptr $ _windowShader pdata) (shadVBOptr $ _textureArrayShader pdata) - wlwiflCounts wallPointsCol windowPoints (_floorTiles w) @@ -68,9 +66,6 @@ doDrawing pdata u = do (_eboPtr $ _silhouetteEBO pdata) ws ) - nWalls <- UMV.read wlwiflCounts 0 - nWins <- UMV.read wlwiflCounts 1 - nFls <- UMV.read wlwiflCounts 2 -- bind wall points, silhouette data, surface geometry uncurry bindShaderBuffers $ unzip [ ( _wallTextureShader pdata, nWalls) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index fad583d1e..d7ae3a6c7 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -1,6 +1,7 @@ module Dodge.Render.ShapePicture ( worldSPic ) where +import Dodge.Creature.Picture.Awareness import Dodge.ShortShow import Dodge.Config.Data import Dodge.Render.InfoBox @@ -25,6 +26,7 @@ import Sound.Data import Geometry.ConvexPoly --import Dodge.Base.Collide +--import Data.Foldable import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M import Control.Lens @@ -33,22 +35,26 @@ import qualified Streaming.Prelude as S -- TODO only filter out shapes outside the range of the furthest shown light source worldSPic :: Configuration -> World -> SPic -worldSPic cfig w = - (mempty, extraPics cfig w) - --(mempty, extraPics cfig w) +worldSPic cfig w = (mempty, extraPics cfig w) <> foldMap (dbArg _prDraw) (filtOn _prPos _props) <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes) --- <> foldMap (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w) <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses) - <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures) + <> foldMap (dbArg _crPict) (filtOn _crPos _creatures) <> foldMap floorItemSPic (filtOn _flItPos _floorItems) <> foldMap btSPic (filtOn _btPos _buttons) <> foldMap mcSPic (filtOn _mcPos _machines) + <> anyTargeting cfig w where filtOn f g = IM.filter (pointIsClose . f) (g w) pointIsClose = cullPoint cfig w +anyTargeting :: Configuration -> World -> SPic +anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr) + where + cr = you w + f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw) + shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x) . rotateSP (fdir x) @@ -80,14 +86,18 @@ extraPics cfig w = pictures (_decorations w) <> cfigdraw Show_bound_box (const drawBoundingBox) <> cfigdraw Show_wall_search_rays (const drawWallSearchRays) <> cfigdraw Show_dda_test (const drawDDATest) - <> cfigdraw Show_far_wall_detect (const drawFarWallDetect) - <> cfigdraw Show_select (const drawWorldSelect) - <> cfigdraw Inspect_wall (const drawInspectWalls) + <> cfigdraw Show_far_wall_detect (const drawFarWallDetect) + <> cfigdraw Show_select (const drawWorldSelect) + <> cfigdraw Inspect_wall (const drawInspectWalls) + <> cfigdraw Cr_awareness (const drawCreatureDisplayTexts) where cfigdraw boption draw | debugOn boption cfig = draw cfig w | otherwise = mempty +drawCreatureDisplayTexts :: World -> Picture +drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) + drawInspectWalls :: World -> Picture drawInspectWalls w = foldMap (drawInspectWall w) $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) @@ -113,9 +123,12 @@ drawWorldSelect w = setLayer DebugLayer . color cyan (a,b) = _wSelect w drawFarWallDetect :: World -> Picture -drawFarWallDetect w = setLayer DebugLayer . color yellow - . concatMap (\q -> line [p,q]) - . map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w) +drawFarWallDetect w = setLayer DebugLayer + . color yellow + . concatMap (\q -> line + [ p + , fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w + ] ) $ runIdentity $ S.toList_ $ streamViewpoints p w where p = _cameraViewFrom w diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 6db8339d3..0a7edf0e6 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -5,7 +5,7 @@ import Picture import Geometry import Shape import Quaternion -import Bound +--import Bound --import Dodge.Data.ForegroundShape import Dodge.Default.Foreground @@ -13,8 +13,8 @@ import Data.List import Data.Maybe import Control.Lens import ShapePicture -import Streaming -import qualified Streaming.Prelude as S +--import Streaming +--import qualified Streaming.Prelude as S highDiagonalMesh :: Point2 @@ -123,7 +123,7 @@ putShape :: Shape -> PSType putShape sh = PutForeground $ defaultForeground & fsPos .~ m & fsRad .~ radBounds bnds - & fsSPic .~ noPic (uncurryV translateSHf (-m) $ sh) + & fsSPic .~ noPic (uncurryV translateSHf (-m) sh) where bnds = (0,0,0,0) -- shapeBounds sh m = midBounds bnds diff --git a/src/Geometry.hs b/src/Geometry.hs index 4f552c3a8..ed9b35d36 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -65,7 +65,7 @@ errorClosestPointOnLine !i !x !y | otherwise = closestPointOnLine x y -- | Debug version of 'closestPointOnLineParam' errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float -errorClosestPointOnLineParam _ !x! y! z +errorClosestPointOnLineParam _ !x !y !z | x == y = dist x z | otherwise = closestPointOnLineParam x y z diff --git a/src/Loop.hs b/src/Loop.hs index 955f0d89a..c745f4361 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -18,18 +18,20 @@ 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. - -> Maybe (Int,Int) -- ^ The window position. + -> T.Text -- ^ Window title + -> WindowConfig +-- -> (Int,Int) -- ^ The window size. +-- -> Maybe (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 -> IO (Maybe world)) -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop. -> IO () -setupLoop spf (xSize,ySize) winpos paramCleanup ioStartWorld sideEffects eventFn = do +setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do initializeAll bracket - (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize winpos)) + (createWindow title winconfig) destroyWindow $ \window -> bracket (glCreateContext window) @@ -68,6 +70,7 @@ doLoop doLoop spf window worldSideEffects eventFn updatedWorld Nothing -> return () + -- | Handle quit events in a manner to exit the loop. Other events handled as -- determined by the custom function, although resize events also change the viewport. applyEventIO :: (world -> Event -> IO (Maybe world)) -> Maybe world -> Event -> IO (Maybe world) @@ -81,18 +84,3 @@ applyEventIO fn mw e = case eventPayload e of mupdate = case mw of Nothing -> return Nothing Just w -> fn w e --- | Create an OpenGL SDL window configuration with a given x and y size. -winConfig :: Int -> Int -> Maybe (Int, Int) -> WindowConfig -winConfig x y winpos = defaultWindow - { windowGraphicsContext = OpenGLContext $ defaultOpenGL - { glProfile = Core Normal 4 3 - , glColorPrecision = V4 8 8 8 8 - } - , windowPosition = theWinPos - , windowInitialSize = V2 (fromIntegral x) (fromIntegral y) - , windowResizable =True - } - where - theWinPos = case winpos of - Just (px,py) -> Absolute (P (V2 (fromIntegral px) (fromIntegral py))) - Nothing -> Wherever diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index a04d76a07..b0287a7b5 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -19,7 +19,7 @@ import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Fusion.Stream.Monadic as VS -import Data.Vector.Fusion.Util +--import Data.Vector.Fusion.Util import Control.Monad.Primitive --import qualified Control.Monad.Parallel as MP @@ -45,19 +45,18 @@ pokeWallsWindowsFloor :: Ptr Float -> Ptr Float -> Ptr Float - -> UMV.MVector (PrimState IO) Int -> [ ( (Point2,Point2) , Point4 ) ] -> [ ( (Point2,Point2) , Point4 ) ] -> [ ( Point3 , Point3 ) ] - -> IO () -pokeWallsWindowsFloor wlptr wiptr flptr counts wls wis fls = do - VS.mapM_ (pokeW wlptr counts 0) (VS.fromList wls) - VS.mapM_ (pokeW wiptr counts 1) (VS.fromList wis) - VS.mapM_ (pokeF flptr counts) (VS.fromList fls) + -> IO (Int,Int,Int) +pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do + wlcounts1 <- VS.foldM (pokeW wlptr) 0 (VS.fromList wls) + wlcounts2 <- VS.foldM (pokeW wiptr) 0 (VS.fromList wis) + flcounts <- VS.foldM (pokeF flptr) 0 (VS.fromList fls) + return (wlcounts1,wlcounts2,flcounts) -pokeF :: Ptr Float -> UMV.MVector (PrimState IO) Int -> (Point3,Point3) -> IO () -pokeF ptr counts (V3 a b c,V3 d e f) = do - i' <- UMV.unsafeRead counts 2 +pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int +pokeF ptr i' (V3 a b c,V3 d e f) = do let i = i' * 6 pokeElemOff ptr (i + 0) a pokeElemOff ptr (i + 1) b @@ -65,11 +64,10 @@ pokeF ptr counts (V3 a b c,V3 d e f) = do pokeElemOff ptr (i + 3) d pokeElemOff ptr (i + 4) e pokeElemOff ptr (i + 5) f - UMV.unsafeModify counts (+1) 2 + return $ i' + 1 -pokeW :: Ptr Float -> UMV.MVector (PrimState IO) Int -> Int -> ((Point2,Point2),Point4) -> IO () -pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do - i' <- UMV.unsafeRead counts iv +pokeW :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int +pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do let i = i' * 8 pokeElemOff ptr (i + 0) a pokeElemOff ptr (i + 1) b @@ -79,12 +77,9 @@ pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do pokeElemOff ptr (i + 5) f pokeElemOff ptr (i + 6) g pokeElemOff ptr (i + 7) h - UMV.unsafeModify counts (+1) iv + return $ i' + 1 -pokeShape - :: Ptr Float - -> Ptr GLushort - -> Ptr GLushort +pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort -> [ShapeObj] -> IO (Int,Int,Int) pokeShape ptr iptr ieptr = VS.foldM (pokeShapeObj ptr iptr ieptr) (0,0,0) . VS.fromList @@ -96,7 +91,7 @@ pokeShapeObj -> (Int,Int,Int) -> ShapeObj -> IO (Int,Int,Int) -{-# INLINE pokeShapeObj #-} +--{-# INLINE pokeShapeObj #-} pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts @@ -105,7 +100,7 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> (Int,Int,Int) -> VS.Stream IO ShapeV -> IO (Int,Int,Int) -{-# INLINE pokeTopPrism #-} +--{-# INLINE pokeTopPrism #-} pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do nv' <- VS.foldM (pokeJustV ptr) nv svs nshapeindices' <- UV.foldM (pokeTopPrismIndex nv iptr) nshapeindices @@ -118,7 +113,7 @@ pokeTopPrismEdgeIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int -{-# INLINE pokeTopPrismEdgeIndex #-} +--{-# INLINE pokeTopPrismEdgeIndex #-} pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff) return $ nedgeindices + 1 @@ -127,7 +122,7 @@ pokeTopPrismIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int -{-# INLINE pokeTopPrismIndex #-} +--{-# INLINE pokeTopPrismIndex #-} pokeTopPrismIndex nv iptr nshapeindices ioff = do pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff) return $ nshapeindices + 1 @@ -168,9 +163,9 @@ pokeJustV :: Ptr Float -> Int -> ShapeV -> IO Int -{-# INLINE pokeJustV #-} +--{-# INLINE pokeJustV #-} pokeJustV ptr nv sh = do - let off i = nv*7 + i +-- pokeArray (advancePtr ptr (off 0)) [a,b,c,d,e,f,g] pokeElemOff ptr (off 0) a pokeElemOff ptr (off 1) b pokeElemOff ptr (off 2) c @@ -180,6 +175,7 @@ pokeJustV ptr nv sh = do pokeElemOff ptr (off 6) g return (nv + 1) where + off i = nv*7 + i V3 a b c = _svPos sh V4 d e f g = _svCol sh diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 01389eb50..90529bace 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -8,7 +8,7 @@ module Shape.Data import Geometry.Data import qualified Data.Vector.Fusion.Stream.Monadic as VS -import Data.Vector.Fusion.Util +--import Data.Vector.Fusion.Util import Control.Lens type Shape = [ShapeObj] diff --git a/stack.yaml b/stack.yaml index 5028917e9..b5e08deb4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,8 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml #resolver: lts-17.1 -resolver: lts-18.5 +resolver: lts-18.28 +#resolver: lts-19.3 # User packages to be built. # Various formats can be used as shown in the example below. @@ -36,8 +37,11 @@ packages: # forks / in-progress versions pinned to a git hash. For example: # extra-deps: -- SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045 -- repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323 + #- SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045 +- sdl2-mixer-1.2.0.0@sha256:6a6b5a46c035c9e77eaf9c244e45de9e4a9b9a110890cfeeb9fa72faa2419cef,4497 +- repa-3.4.1.5@sha256:4d94845e66d668345130f75f5de8f7c69139b91495c8c4b5a825014e8985e2fd,3562 + #- repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323 + #- sdl2-mixer-1.1.0@sha256:c809aecd91ebf9c759af66eebaa4f45f766f2603c13a73412abfd0bd1e02071a,3067 # # for threadscope #- cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa8779b23b2b67a9,4075 #- ghc-events-0.15.1@sha256:b4052e98694a6426f46fb6ebb250b06d6f68a14fa0b7ceb7c01282c6bb5fe47e,3757