Reify block drawing

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
+    
+

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

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

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

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 = []

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'

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))

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
+

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

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

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]

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)                          

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
+            %~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80
-                <>  horPipe 80 0 (70 *.* cardVec edge))))
+                <>  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
+            %~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80
-                <>  horPipe 80 0 (70 *.* cardVec edge))))
+                <>  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)

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   )