Implement randomised markings on sensors

src/Color.hs

@@ -1,7 +1,10 @@
-module Color
+module Color where
-  where
 import Geometry
 
+data PaletteColor = Red | Green | Blue | Yellow | Cyan 
+    | Magenta | Rose  | Violet | Azure | Aquamarine | Chartreuse | Orange | White | Black
+  deriving (Eq,Ord,Enum,Show)
+
 type RGBA  = Point4
 type Color = Point4
 
@@ -40,6 +43,24 @@ black     = V4   0   0   0 1
 {-# INLINE white      #-}
 {-# INLINE black      #-}
 
+paletteToColor :: PaletteColor -> Color
+{-# INLINE paletteToColor #-}
+paletteToColor pc = case pc of
+    Red         -> red       
+    Green       -> green     
+    Blue        -> blue      
+    Yellow      -> yellow    
+    Cyan        -> cyan      
+    Magenta     -> magenta   
+    Rose        -> rose      
+    Violet      -> violet    
+    Azure       -> azure     
+    Aquamarine  -> aquamarine
+    Chartreuse  -> chartreuse
+    Orange      -> orange    
+    White       -> white     
+    Black       -> black     
+
 mixColors :: Float -> Float -> Color -> Color -> Color
 {-# INLINE mixColors #-}
 mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = 
@@ -74,6 +95,7 @@ greyN :: Float -> Color
 greyN x = toV4 (x,x,x,1)
 
 numColor :: Int -> Color
+{-# INLINE numColor #-}
 numColor 0  = toV4 (1,0,0,1) 
 numColor 1  = toV4 (0,1,0,1) 
 numColor 2  = toV4 (0,0,1,1) 

src/Dodge/Creature/Inanimate.hs

@@ -23,10 +23,10 @@ import Geometry
 --import Geometry.Vector3D
 import Shape
 import Dodge.SoundLogic
+import LensHelp
 
 import System.Random
 import Data.List
-import Control.Lens
 
 barrel :: Creature
 barrel = defaultInanimate
@@ -89,7 +89,7 @@ damToExpBarrel :: [Damage] -> Creature -> Creature
 damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
   where 
     (pierceDam,otherDam) = partition isPierce ds
-    isPierce (Damage {_dmType = Piercing{}}) = True
+    isPierce Damage{_dmType = Piercing{}} = True
     isPierce _             = False
 
 damToExpBarrel' :: Damage -> Creature -> Creature
@@ -98,8 +98,8 @@ damToExpBarrel' dm cr = case _dmType dm of
         $ over crHP (\hp -> hp - div amount 200) cr
     PoisonDam -> cr
     SparkDam -> cr
-    PushDam -> cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* (_dePushBack $ _dmEffect dm))
+    PushDam -> cr LensHelp.& crPos .+.+~ (1 / _crMass cr *.* _dePushBack (_dmEffect dm))
-    dt  -> cr Control.Lens.& crHP -~ amount
+    _  -> cr LensHelp.& crHP -~ amount
   where
     amount = _dmAmount dm
     int = _dmAt dm

src/Dodge/Data/DamageType.hs

@@ -25,6 +25,7 @@ data DamageType = Piercing
     | PoisonDam 
   deriving (Eq,Ord,Show)
 
+-- this should possibly be pushed into the damage type
 data DamageEffect
     = PushDamage 
         { _dePush :: Float 

src/Dodge/Floor.hs

@@ -12,7 +12,7 @@ import Dodge.Data.DamageType
 --import Dodge.Placement.Instance.Button
 import Dodge.Tree
 import Dodge.Annotation
-import Dodge.Placement.Instance.Sensor
+--import Dodge.Placement.Instance.Sensor
 --import Dodge.Creature
 --import Dodge.LevelGen.Data
 --import Dodge.LevelGen.Switch

src/Dodge/Item/Equipment.hs

@@ -122,7 +122,7 @@ shieldWallDamage :: Damage -> Wall -> Int -> World -> World
 shieldWallDamage dm wl crid w = case _dmType dm of
     Lasering -> 
         w & instantParticles .:~ lasRayAt 5 (da +.+ normalizeV (df -.- da)) (reflDirWall df da wl)
-    d | isMovementDam dm -> w & creatures . ix crid . crState . crDamage .:~ dm
+    _ | isMovementDam dm -> w & creatures . ix crid . crState . crDamage .:~ dm
     _ -> w
   where
     df = _dmFrom dm

src/Dodge/LevelGen.hs

@@ -9,7 +9,7 @@ import Dodge.Initialisation
 --import Dodge.RandomHelp
 import Dodge.LevelGen.Data
 import Dodge.Tree
-import Dodge.LevelGen.LevelStructure
+--import Dodge.LevelGen.LevelStructure
 
 import Data.Tree
 import System.Random

src/Dodge/LevelGen/Data.hs

@@ -4,10 +4,12 @@ module Dodge.LevelGen.Data where
 import Dodge.Data
 import Picture
 import Geometry
+--import Color
 import Shape.Data
 import Data.Tile
 
 import qualified Data.Set as S
+import qualified Data.Map.Strict as M
 import Control.Lens
 import Control.Monad.State
 import System.Random
@@ -16,7 +18,7 @@ import qualified Data.IntMap.Strict as IM
 --import Data.Bifunctor
 
 data PSType = PutCrit {_unPutCrit :: Creature}
-    | PutMachine Color [Point2] Machine
+    | PutMachine { _putMachineColor :: Color, _putMachinePoly :: [Point2], _unPutMachine :: Machine }
     | PutLS LightSource
     | PutButton Button
     | PutProp Prop
@@ -34,6 +36,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutShape Shape
     | PutWorldUpdate (PlacementSpot -> World -> World)
     | PutNothing
+    | PutUsingGenParams (GenWorld -> (GenWorld,PSType))
     | PutID { _putID :: Int}
 -- maybe there is a monadic implementation of this?
 -- add room effect for any placement spot?
@@ -56,6 +59,7 @@ data Placement
         , _plMID    :: Maybe Int
         , _plIDCont :: Placement -> Maybe Placement 
         }
+    | PlacementGenUpdate (GenParams -> Placement -> (GenParams, Placement)) Placement
     | PlacementUsingPos Point3 (Point3 -> Placement)  -- allows a placement to use a shifted position
     | RandomPlacement {_unRandomPlacement :: State StdGen Placement}
     | PickOnePlacement Int Placement
@@ -152,6 +156,20 @@ data RoomPosType
     | RoomPosOffPath
     | RoomPosExLink
   deriving (Eq,Ord,Show)
+data DecorationShape = PlusDecoration | SquareDecoration | CircleDecoration
+    | ThreeLineDecoration
+  deriving (Eq,Ord,Enum,Show)
+
+newtype GenParams = GenParams
+    { _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape)
+    }
+
+data GenWorld = GenWorld
+    { _gWorld       :: World
+    , _gPlacements  :: IM.IntMap [(Placement,Int)]
+    , _gRooms       :: IM.IntMap Room
+    , _gParams      :: GenParams
+    }
 
 makeLenses ''Room
 makeLenses ''PSType
@@ -161,6 +179,8 @@ makeLenses ''RoomLink
 makeLenses ''RoomPos
 makeLenses ''RoomPosType
 makeLenses ''RPLinkStatus
+makeLenses ''GenWorld
+makeLenses ''GenParams
 
 spNoID :: PlacementSpot -> PSType -> Placement
 spNoID ps pst = Placement ps pst Nothing (const Nothing)
@@ -231,6 +251,7 @@ addPlmnt pl pl2 = case pl2 of
     (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
     (Placement ps pt mi f) -> Placement ps pt mi (fmap g f)
     PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet"
+    PlacementGenUpdate {} -> error "not written how to combine PlacementGenUpdate with others yet"
   where
     g Nothing = Just pl
     g (Just pl') = Just $ addPlmnt pl pl'

src/Dodge/LevelGen/LevelStructure.hs

@@ -1,24 +1,33 @@
-{-# LANGUAGE TemplateHaskell #-}
+--{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
-module Dodge.LevelGen.LevelStructure where
+module Dodge.LevelGen.LevelStructure 
+    ( module Dodge.LevelGen.Data
+    , worldToGenWorld
+    ) where
 import Dodge.LevelGen.Data
 --import Dodge.Tree.Compose.Data
 import Dodge.Data
+import Dodge.RandomHelp
+import Color
 
 --import Data.Tree
 import qualified Data.IntMap.Strict as IM
-import Control.Lens
+import qualified Data.Map.Strict as M
---import System.Random
+--import Control.Lens
+import Control.Monad.State
+import System.Random
 
-data GenWorld = GenWorld
-    { _gWorld       :: World
-    , _gPlacements  :: IM.IntMap [(Placement,Int)]
-    , _gRooms       :: IM.IntMap Room
-    }
 worldToGenWorld :: IM.IntMap Room -> World -> GenWorld
 worldToGenWorld rms w = GenWorld 
     { _gWorld = w
     , _gPlacements = IM.empty
     , _gRooms = rms
+    , _gParams = evalState generateGenParams (_randGen w)
     }
-makeLenses ''GenWorld
+
+generateGenParams :: RandomGen g => State g GenParams
+generateGenParams = do
+    cols <- shuffle [Red .. Orange]
+    shps <- shuffle [PlusDecoration ..]
+    return . GenParams . M.fromList . zip [Flaming,Lasering,Electrical]
+        $ zip cols shps

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -63,11 +63,6 @@ bulPenCr' bt p cr w = w
     & bulletHitSound ep
     & creatures . ix cid . crState . crDamage .++~
         damageGamut 50 50 d1 sp p ep
---        [Damage Piercing 50 sp p ep NoDamageEffect
---        ,Damage Blunt    50  sp p ep NoDamageEffect
---        ,Damage TorqueDam 1 sp p ep $ TorqueDamage d1
---        ,Damage PushDam 1 sp p ep . PushBackDamage $ 3 *.* (ep -.- sp)
---        ] 
   where 
     (d1,_)  = randomR (-0.7,0.7) $ _randGen w
     cid = _crID cr

src/Dodge/Placement/Instance/Sensor.hs

@@ -7,10 +7,12 @@ import Dodge.LightSource
 import Dodge.Data
 import Dodge.LevelGen.Data
 import Dodge.Default
+import Dodge.Placement.TopDecoration
 import Geometry
 import ShapePicture
 import Shape
 
+import qualified Data.Map.Strict as M
 import Control.Lens
 import Data.Either
 
@@ -19,14 +21,13 @@ damageSensor
     -> Float
     -> (Machine -> World -> World)
     -> PlacementSpot -> Placement
-damageSensor damF wdth upf ps = pContID ps (PutLS theLS)
+damageSensor dt wdth upf ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
-    $ \lsid -> Just $ spNoID ps $ PutMachine yellow (reverse $ square wdth) defaultMachine
+    $ \lsid -> Just $ spNoID ps $ PutUsingGenParams 
-        { _mcDraw = sensorSPic wdth
+    $ \gw -> (,) gw $ PutMachine yellow (reverse $ square wdth) defaultMachine
-        , _mcUpdate = \mc -> upf mc . sensorUpdate damF mc
+        { _mcDraw = sensorSPic wdth $ _sensorCoding (_gParams gw) M.! dt
+        , _mcUpdate = \mc -> upf mc . sensorUpdate dt mc
         , _mcLSs = [lsid]
         }
-  where
-    theLS = lsPosCol (V3 0 0 30) 0.1
 
 lightSensor :: Float -> (Machine -> World -> World) -> PlacementSpot -> Placement
 lightSensor = damageSensor Lasering
@@ -51,6 +52,9 @@ damageUsing dt dm
     | _dmType dm == dt = Left $ _dmAmount dm
     | otherwise = Right 0
 
-sensorSPic :: Float -> Machine -> SPic
+sensorSPic :: Float -> (PaletteColor,DecorationShape) -> Machine -> SPic
-sensorSPic wdth _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth)
+sensorSPic wdth (pc,ds) _ = ( (colorSH yellow $ upperPrismPoly 25 (square wdth))
+    <> decorationToShape ds wdth wdth 25 col col
     , mempty )
+  where
+    col = paletteToColor pc

src/Dodge/Placement/Instance/Tank.hs

@@ -1,14 +1,23 @@
-module Dodge.Placement.Instance.Tank where
+module Dodge.Placement.Instance.Tank 
+    ( tankSquareDec
+    , roundTank
+    , roundTankCross
+    ) where
 import Dodge.Data
 --import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
 import Dodge.Default.Wall
+--import Dodge.Placement.TopDecoration
 import Geometry
 import Shape
 import Color
 --import Quaternion
 
+tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape) 
+    -> Color -> Color -> Placement
+tankSquareDec dec = tankShape (square 20) (dec 20 20 31)
+
 tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
 tankShape baseshape facade col col' = ps0jPushPS
     (PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col')
@@ -25,58 +34,3 @@ roundTankCross :: Color -> Color -> Placement
 roundTankCross = tankShape (polyCirc 4 20) 
     $ \_ c -> colorSH c $ thinHighBar 31 (V2 20 0) (V2 (-20) 0)
         <> thinHighBar 31 (V2 0 20) (V2 0 (-20))
-
-tankRectCross :: Float -> Float -> Color -> Color -> Placement
-tankRectCross = tankRectDecorate $ \ w h _ c -> colorSH c $
-    thinHighBar 31 (V2 w 0) (V2 (-w) 0) 
-    <> thinHighBar 31 (V2 0 h) (V2 0 (-h))
-
-tankSquareCross :: Color -> Color -> Placement
-tankSquareCross = tankRectCross 20 20
-
-tankRectDecorate :: (Float -> Float -> Color -> Color -> Shape) 
-    -> Float -> Float -> Color -> Color -> Placement
-tankRectDecorate f w h = tankShape (rectWH w h) (f w h)
-
-tankRect :: Float -> Float -> Color -> Color -> Placement
-tankRect = tankRectDecorate g 
-  where
-    g w h _ col = colorSH col $ foldMap f 
-        [(w',-w',h',h')
-        ,(w',-w',-h',-h')
-        ,(w',w',h',-h')
-        ,(-w',-w',h',-h')
-        ]
-      where
-        w' = w - 1.5
-        h' = h - 1.5
-        f (a,c,b,d) = thinHighBar 31 (V2 a b) (V2 c d)
-
-tankSquare :: Color -> Color -> Placement
-tankSquare = tankRect 20 20
-
-tankRectEmboss :: Float -> Float -> Color -> Color -> Placement
-tankRectEmboss = tankRectDecorate f
-  where
-    f w h _ c = embossingR
-        <> rotateSH pi embossingR
-        <> colorSH c (thinHighBar 38 (V2 (-0.3*w) 0) (V2 (0.3*w) 0))
-      where
-        w' = 0.3 * w
-        embossingR = colorSH c $ prismPoly 
-            [V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
-            [V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
-
-tankSquareEmboss :: Color -> Color -> Placement
-tankSquareEmboss = tankRectEmboss 20 20
-
-tankRectEmboss4 :: Float -> Float -> Color -> Color -> Placement
-tankRectEmboss4 = tankRectDecorate g
-  where
-    g w h _ c = colorSH c $ foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
-      where
-        f (a,b) = translateSH (V3 (a/2) (b/2) 31) embossing
-        embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
-
-tankSquareEmboss4 :: Color -> Color -> Placement
-tankSquareEmboss4 = tankRectEmboss4 20 20

src/Dodge/Placement/PlaceSpot.hs

@@ -11,7 +11,7 @@ import Dodge.Data
 import Dodge.Path
 import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
-import Dodge.LevelGen.Data
+--import Dodge.LevelGen.Data
 import Dodge.Default.Wall
 import Dodge.ShiftPoint
 --import Dodge.RandomHelp
@@ -39,6 +39,8 @@ placeSpot (w,rm) plmnt = case plmnt of
     PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
     RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
     PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
+    PlacementGenUpdate f pl -> let (gp,pl') = f (_gParams w) pl
+        in placeSpot (w & gParams .~ gp,rm) pl'
   where
     shift = _rmShift rm
 
@@ -109,6 +111,8 @@ placeSpotID ps pt w = case pt of
     PutNothing              -> (0,w)
     PutID i                 -> (i, w)
     PutWorldUpdate f        -> (0,w & gWorld %~ f ps)
+    PutUsingGenParams f     ->  let (w',pt') = f w
+                                in placeSpotID ps pt' w'
   where 
     p@(V2 px py) = _psPos ps
     p' = V3 px py 0

src/Dodge/Placement/Shift.hs

@@ -20,3 +20,4 @@ shiftPlacement shift plmnt = case plmnt of
         (fmap (shiftPlacement shift) f)
     RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
     PickOnePlacement i pl -> PickOnePlacement i (shiftPlacement shift pl)
+    PlacementGenUpdate f pl -> PlacementGenUpdate f (shiftPlacement shift pl)

src/Dodge/Placement/TopDecoration.hs

@@ -0,0 +1,62 @@
+module Dodge.Placement.TopDecoration where
+import Dodge.Room.Foreground
+import Dodge.LevelGen.Data
+import Shape
+import Geometry
+import Color
+
+decorationToShape :: DecorationShape
+    -> Float -> Float -> Float -> Color -> Color -> Shape
+decorationToShape dec = case dec of
+    PlusDecoration -> plusDecoration
+    SquareDecoration -> squareDecoration
+    CircleDecoration -> circleDecoration
+    ThreeLineDecoration -> threeLineDecoration
+
+midBarDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
+midBarDecoration w h z _ c = embossingR
+    <> rotateSH pi embossingR
+    <> colorSH c (thinHighBar (z + 7) (V2 (-0.3*w) 0) (V2 (0.3*w) 0))
+  where
+    w' = 0.3 * w
+    embossingR = colorSH c $ prismPoly 
+        [V3 w h z,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) z]
+        [V3 w' h z,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) z]
+
+fourEmbossDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
+fourEmbossDecoration w h z _ c = colorSH c $ foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
+  where
+    f (a,b) = translateSH (V3 (a/2) (b/2) z) embossing
+    embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
+
+plusDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
+plusDecoration w h z _ c = colorSH c $ thinHighBar z (V2 w 0) (V2 (-w) 0)
+    <> thinHighBar z (V2 0 h) (V2 0 (-h))
+
+squareDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
+squareDecoration w h z _ col = colorSH col $ foldMap f 
+    [(w',-w',h',h')
+    ,(w',-w',-h',-h')
+    ,(w',w',h',-h')
+    ,(-w',-w',h',-h')
+    ]
+  where
+    w' = w - 1.5
+    h' = h - 1.5
+    f (a,c,b,d) = thinHighBar z (V2 a b) (V2 c d)
+
+circleDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
+circleDecoration w _ z _ c = colorSH c $ foldMap toprail (take 8 [0,pi/4..]) 
+  where
+    toprail a = rotateSH a $ thinHighBar z (V2 0 w) (rotateV (pi/4) $ V2 0 w)
+
+threeLineDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
+threeLineDecoration w h z _ col = colorSH col $ foldMap f 
+    [(w',-w',h',h')
+    ,(w',-w',0,0)
+    ,(w',-w',-h',-h')
+    ]
+  where
+    w' = w - 1.5
+    h' = h - 1.5
+    f (a,c,b,d) = thinHighBar z (V2 a b) (V2 c d)

src/Dodge/Room/SensorDoor.hs

@@ -38,7 +38,6 @@ sensorRoom senseType n = do
     let doorroom = triggerDoorRoom n
     return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
 
-
 sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement
 sensAboveDoor sensetype wth ps = extTrigLitPos 
     (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))

src/Dodge/Room/Tanks.hs

@@ -6,11 +6,13 @@ import Dodge.Room.Procedural
 import Dodge.Room.Foreground
 --import Dodge.Room.RoadBlock
 import Dodge.Placement.Instance
+import Dodge.Placement.TopDecoration
 import Dodge.PlacementSpot
 --import Padding
 import Color
 --import Shape
 import LensHelp
+--import Geometry
 
 --import Data.Maybe
 --import Data.Tree
@@ -20,12 +22,12 @@ import qualified Data.Set as S
 
 randomTank :: RandomGen g => State g Placement
 randomTank = takeOne $ map (\f -> f (dim orange) orange)
-    [ tankSquareEmboss4
+    [ tankSquareDec fourEmbossDecoration
-    , tankSquareEmboss
+    , tankSquareDec midBarDecoration
-    , tankSquare
+    , tankSquareDec squareDecoration
     , roundTank
     , roundTankCross
-    , tankSquareCross
+    , tankSquareDec plusDecoration
     ]
 
 tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room