From c3a5b9d5beff1ed540d404dafe684cdc80ff9303 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 25 Jul 2022 01:27:39 +0100 Subject: [PATCH] Reify block drawing --- src/Dodge/Block/Draw.hs | 19 +++++++++++++++++++ src/Dodge/Bullet.hs | 3 ++- src/Dodge/Data.hs | 2 +- src/Dodge/Data/Block.hs | 14 ++++++++++++-- src/Dodge/Data/Magnet.hs | 12 +++++++++--- src/Dodge/Default/Block.hs | 2 +- src/Dodge/Item/Equipment.hs | 5 ++--- src/Dodge/Magnet/Update.hs | 10 ++++++++++ src/Dodge/MagnetBuBu.hs | 11 +++++++++++ src/Dodge/Placement/Instance/Block.hs | 8 +++++--- src/Dodge/Placement/Instance/Tank.hs | 2 +- src/Dodge/Placement/PlaceSpot/Block.hs | 2 +- src/Dodge/Render/ShapePicture.hs | 3 ++- src/Dodge/Room/Tanks.hs | 12 +++++++----- src/Dodge/Update.hs | 3 ++- 15 files changed, 85 insertions(+), 23 deletions(-) create mode 100644 src/Dodge/Block/Draw.hs create mode 100644 src/Dodge/Magnet/Update.hs create mode 100644 src/Dodge/MagnetBuBu.hs diff --git a/src/Dodge/Block/Draw.hs b/src/Dodge/Block/Draw.hs new file mode 100644 index 000000000..4876ad7b8 --- /dev/null +++ b/src/Dodge/Block/Draw.hs @@ -0,0 +1,19 @@ +module Dodge.Block.Draw + where +import Shape +import Dodge.Data.Block +import ShapePicture + +drawBlock :: BlockDraw -> Block -> SPic +drawBlock bd = case bd of + BlockDrawMempty -> const mempty + BlockDraws bds -> \bl -> foldMap (flip drawBlock bl) bds + BlockDrawColHeightPoss col h ps -> const $ noPic $ colorSH col (upperPrismPoly h $ ps) + BlockDrawBlSh x -> \bl -> noPic $ doBlSh x bl + +doBlSh :: BlSh -> Block -> Shape +doBlSh bs = case bs of + BlShMempty -> const mempty + BlShConst sh -> const sh + + diff --git a/src/Dodge/Bullet.hs b/src/Dodge/Bullet.hs index 1bbd3fcab..99fd04dfd 100644 --- a/src/Dodge/Bullet.hs +++ b/src/Dodge/Bullet.hs @@ -2,6 +2,7 @@ module Dodge.Bullet ( updateBullet , useAmmoParams ) where +import Dodge.MagnetBuBu import qualified ListHelp as List import Dodge.EnergyBall import Dodge.Creature.Test @@ -59,7 +60,7 @@ mvBullet x w bt' partspawn <- bulletSpawn bt' return $ partspawn p w' hitstream = thingsHit p (p +.+ vel) w - bt = foldr (\mg b -> _mgField mg mg b) bt' (_magnets w) + bt = foldr (\mg b -> doMagnetBuBu (_mgField mg) mg b) bt' (_magnets w) & buState .~ NormalBulletState dodrag = case _buTrajectory bt of BasicBulletTrajectory -> buVel .*.*~ drag diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 152e91987..ade4bb244 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -299,7 +299,7 @@ data World = World , _lSelect :: Point2 , _rSelect :: Point2 } - --deriving (Eq,Show,Read) +-- deriving (Eq,Show,Read) data WorldHammer = SubInvHam | DoubleMouseHam diff --git a/src/Dodge/Data/Block.hs b/src/Dodge/Data/Block.hs index 124d666ac..b7a5aac03 100644 --- a/src/Dodge/Data/Block.hs +++ b/src/Dodge/Data/Block.hs @@ -1,9 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.Block where +import Shape.Data +import Color import Dodge.Data.Material import Dodge.Data.PathGraph -import ShapePicture import Geometry import Control.Lens import qualified Data.IntSet as IS @@ -17,7 +18,16 @@ data Block = Block , _blDir :: Float , _blHeight :: Float , _blMaterial :: Material - , _blDraw :: Block -> SPic + , _blDraw :: BlockDraw --Block -> SPic , _blObstructs :: [(Int,Int,PathEdge)] } + deriving (Eq,Ord,Show,Read) +data BlockDraw = BlockDrawMempty + | BlockDrawBlSh BlSh + | BlockDraws [BlockDraw] + | BlockDrawColHeightPoss Color Float [Point2] + deriving (Eq,Ord,Show,Read) +data BlSh = BlShMempty + | BlShConst Shape + deriving (Eq,Ord,Show,Read) makeLenses ''Block diff --git a/src/Dodge/Data/Magnet.hs b/src/Dodge/Data/Magnet.hs index 79bcc2352..6f9bf8493 100644 --- a/src/Dodge/Data/Magnet.hs +++ b/src/Dodge/Data/Magnet.hs @@ -1,14 +1,20 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.Magnet where -import Dodge.Data.Bullet import Geometry.Data import Control.Lens +newtype MagnetUpdate = MagnetUpdateTimer Int + deriving (Eq,Ord,Show,Read) +data MagnetBuBu = MagnetBuId + | MagnetBuBuCurveAroundField Float Float + deriving (Eq,Ord,Show,Read) + data Magnet = Magnet { _mgID :: Int - , _mgUpdate :: Magnet -> Maybe Magnet + , _mgUpdate :: MagnetUpdate , _mgPos :: Point2 - , _mgField :: Magnet -> Bullet -> Bullet + , _mgField :: MagnetBuBu } + deriving (Eq,Ord,Show,Read) makeLenses ''Magnet diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs index a6d919b64..3ecf670ed 100644 --- a/src/Dodge/Default/Block.hs +++ b/src/Dodge/Default/Block.hs @@ -11,7 +11,7 @@ defaultBlock = Block , _blFootprint = [] , _blPos = 0 , _blDir = 0 - , _blDraw = const mempty + , _blDraw = BlockDrawMempty , _blHeight = 100 , _blMaterial = Stone , _blObstructs = [] diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index 8b7ef7d3c..67a5e83e2 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -35,7 +35,6 @@ import Dodge.Creature.Test import Dodge.Creature.HandPos import Dodge.Wall import Dodge.Wall.ForceField -import Dodge.Magnet import Picture import Geometry import qualified IntMapHelp as IM @@ -56,9 +55,9 @@ useMagShield it cr w = w & magnets . at mgid ?~ themagnet where themagnet = Magnet {_mgID = mgid - ,_mgUpdate = Just . (mgUpdate .~ const Nothing) + ,_mgUpdate = MagnetUpdateTimer 1 ,_mgPos = _crPos cr - ,_mgField = curveAroundField 50 200 + ,_mgField = MagnetBuBuCurveAroundField 50 200 } mgid = case it ^? itAttachment . atMInt . _Just of Just mgid' -> mgid' diff --git a/src/Dodge/Magnet/Update.hs b/src/Dodge/Magnet/Update.hs new file mode 100644 index 000000000..00452f0cb --- /dev/null +++ b/src/Dodge/Magnet/Update.hs @@ -0,0 +1,10 @@ +module Dodge.Magnet.Update + where +import Dodge.Data.Magnet +import Control.Lens + +doMagnetUpdate :: MagnetUpdate -> Magnet -> Maybe Magnet +doMagnetUpdate mu = case mu of + MagnetUpdateTimer i + | i < 1 -> const Nothing + | otherwise -> Just . (mgUpdate .~ MagnetUpdateTimer (i - 1)) diff --git a/src/Dodge/MagnetBuBu.hs b/src/Dodge/MagnetBuBu.hs new file mode 100644 index 000000000..adfb8fd98 --- /dev/null +++ b/src/Dodge/MagnetBuBu.hs @@ -0,0 +1,11 @@ +module Dodge.MagnetBuBu + where +import Dodge.Magnet +import Dodge.Data.Bullet +import Dodge.Data.Magnet + +doMagnetBuBu :: MagnetBuBu -> Magnet -> Bullet -> Bullet +doMagnetBuBu mbb = case mbb of + MagnetBuId -> const id + MagnetBuBuCurveAroundField x y -> curveAroundField x y + diff --git a/src/Dodge/Placement/Instance/Block.hs b/src/Dodge/Placement/Instance/Block.hs index b08870031..c41612b26 100644 --- a/src/Dodge/Placement/Instance/Block.hs +++ b/src/Dodge/Placement/Instance/Block.hs @@ -8,11 +8,13 @@ import Shape import Dodge.Default.Wall import Dodge.Default.Block -decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType +--decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType +decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps where bl = defaultBlock - & blDraw .~ (\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl')) + & blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps),BlockDrawBlSh decf] + --(\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl')) & blHeight .~ h & blMaterial .~ mat wl = defaultWall @@ -23,4 +25,4 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps & wlHeight .~ h lowBlock :: Material -> Color -> Float -> [Point2] -> PSType -lowBlock = decoratedBlock (const mempty) +lowBlock = decoratedBlock BlShMempty diff --git a/src/Dodge/Placement/Instance/Tank.hs b/src/Dodge/Placement/Instance/Tank.hs index bb5ae0f19..714dfbd0e 100644 --- a/src/Dodge/Placement/Instance/Tank.hs +++ b/src/Dodge/Placement/Instance/Tank.hs @@ -18,7 +18,7 @@ tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape) tankSquareDec dec = tankShape (square 20) (dec 20 20 31) tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement -tankShape baseshape facade col col' = sps0 $ decoratedBlock (const $ facade col col') Metal col 31 baseshape +tankShape baseshape facade col col' = sps0 $ decoratedBlock (BlShConst $ facade col col') Metal col 31 baseshape -- = sps0 $ PutBlock bl wl $ reverse baseshape -- where -- bl = defaultBlock diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 191c50f06..97f35387a 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -74,7 +74,7 @@ plLineBlock basePane blwidth a b gw = ( 0 , _blObstructs = [] , _blMaterial = _wlMaterial basePane , _blHeight = 100 - , _blPos = p, _blDraw = const mempty } + , _blPos = p, _blDraw = BlockDrawMempty } ) insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3] diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 057987a04..df42180e0 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.Block.Draw import Dodge.Machine.Draw import Dodge.LinearShockwave.Draw import Dodge.Prop.Draw @@ -67,7 +68,7 @@ worldSPic cfig w = singleSPic (mempty, extraPics cfig w) <> foldup drawProp' (filtOn _prPos _props) <> foldup drawProjectile (filtOn _prjPos _projectiles) - <> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) + <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks) <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes) <> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses) <> foldup drawCreature (filtOn _crPos _creatures) diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index 864a85bcc..4f06858a0 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -14,7 +14,6 @@ import Dodge.Base.CardinalPoint --import Padding import Color import Shape -import ShapePicture import LensHelp import Geometry @@ -32,14 +31,17 @@ randomTank = takeOne $ map (\f -> f (dim orange) orange) , tankSquareDec plusDecoration ] +-- dup with randEdgeTanks? randEdgeTank :: RandomGen g => State g Placement randEdgeTank = do edge <- takeOne cardList basetank <- randomTank return $ basetank & plType . putBlock . blDraw - %~ fmap (<> noPic ( colorSH orange (verticalPipe 80 - <> horPipe 80 0 (70 *.* cardVec edge)))) + %~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80 + <> horPipe 80 0 (70 *.* cardVec edge)))] ) + -- %~ fmap (<> noPic ( colorSH orange (verticalPipe 80 + -- <> horPipe 80 0 (70 *.* cardVec edge)))) -- 70 is a guess, the true value depends on the distance to the wall & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0 && rpOffPathFromEdge (PathFromEdge edge 0) rp) @@ -50,8 +52,8 @@ randEdgeTanks i = do basetank <- randomTank return $ replicate i $ basetank & plType . putBlock . blDraw - %~ fmap (<> noPic ( colorSH orange (verticalPipe 80 - <> horPipe 80 0 (70 *.* cardVec edge)))) + %~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80 + <> horPipe 80 0 (70 *.* cardVec edge)))] ) -- 70 is a guess, the true value depends on the distance to the wall & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0 && rpOffPathFromEdge (PathFromEdge edge 0) rp) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index e8eab1e05..4c687f365 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -4,6 +4,7 @@ Module : Dodge.Update Description : Simulation update -} module Dodge.Update ( updateUniverse ) where +import Dodge.Magnet.Update import Dodge.TmTm import Color import Dodge.DrWdWd @@ -114,7 +115,7 @@ functionalUpdate w = checkEndGame . over uvWorld updateClouds . over uvWorld updateGusts . over uvWorld zoneClouds - . over uvWorld (updateMIM magnets _mgUpdate ) + . over uvWorld (updateMIM magnets (doMagnetUpdate . _mgUpdate) ) . over uvWorld (updateIMl' _terminals tmUpdate ) -- . updateIMl _machines mcChooseUpdate . over uvWorld (updateIMl' _machines updateMachine )