justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Simplify tank decorations

Browse Source
This commit is contained in:
justin
2025-12-07 20:11:54 +00:00
parent 6e5d2f147a
commit 79f86a3158
9 changed files with 133 additions and 124 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Machine.hs
+1 -1
View File
@@ -35,7 +35,6 @@ data Machine = Machine
, _mcDamage :: [Damage]
, _mcType :: MachineType
, _mcMounts :: M.Map ObjectType Int
, _mcWidth :: Float
}
data MachineType
@@ -46,6 +45,7 @@ data MachineType
| McTurret {_mctTurret :: Turret}
-- | McStorage
-- | McDistributer
-- | McSynthesiser
data Turret = Turret
{ _tuWeapon :: Int
src/Dodge/Default.hs
-1
View File
@@ -39,7 +39,6 @@ defaultMachine =
, _mcDamage = []
, _mcType = McStatic
, _mcMounts = mempty
, _mcWidth = 10
}
defaultButton :: Button
src/Dodge/Machine/Draw.hs
+8 -12
View File
@@ -18,8 +18,8 @@ drawMachine cw mc = case _mcType mc of
McStatic -> mempty
McTerminal -> terminalSPic lw mc
McTurret tu -> drawBaseMachine 20 mc <> drawTurret lw tu mc
McDamSensor se -> drawBaseMachine 25 mc <> drawDamSensor gp se mc
McProxSensor se -> drawBaseMachine 25 mc <> drawProxSensor se mc
McDamSensor se -> drawBaseMachine 25 mc <> drawDamSensor gp se
McProxSensor {} -> drawBaseMachine 25 mc
where
lw = cw ^. lWorld
gp = cw ^. cwGen . cwgParams . sensorCoding
@@ -27,15 +27,11 @@ drawMachine cw mc = case _mcType mc of
drawDamSensor ::
M.Map SensorType (PaletteColor, DecorationShape) ->
DamageSensor ->
Machine ->
SPic
drawDamSensor gp sens mc = fold $ do
drawDamSensor gp sens = fold $ do
let st = sens ^. sensType
x <- gp ^? ix st
return $ sensorSPic x mc
drawProxSensor :: ProximitySensor -> Machine -> SPic
drawProxSensor _ = const mempty
return $ sensorSPic x
terminalSPic :: LWorld -> Machine -> SPic
terminalSPic lw = noPic . terminalShape lw
@@ -71,7 +67,7 @@ drawBaseMachine h mc =
. colorSH (mcColor mc)
. upperBox Medium Typical h
. square
$ _mcWidth mc
$ 10
mcColor :: Machine -> Color
mcColor mc = case mc ^. mcType of
@@ -87,8 +83,8 @@ drawTurret lw tu mc = fold $ do
itm <- lw ^? items . ix (tu ^. tuWeapon)
return $ overPosSP (turretItemOffset itm tu mc) (itemSPic itm)
sensorSPic :: (PaletteColor, DecorationShape) -> Machine -> SPic
sensorSPic (pc, ds) mc = noPic $ decorationToShape ds w w 25 col col
sensorSPic :: (PaletteColor, DecorationShape) -> SPic
sensorSPic (pc, ds) = noPic $ decorationToShape ds w w 25 col
where
col = paletteToColor pc
w = _mcWidth mc
w = 10
src/Dodge/Placement/Instance/Block.hs
+5 -2
View File
@@ -1,12 +1,15 @@
module Dodge.Placement.Instance.Block where
module Dodge.Placement.Instance.Block (
decoratedBlock,
lowBlock,
) where
import Shape
import Color
import Dodge.Data.GenWorld
import Dodge.Default.Block
import Dodge.Default.Wall
import Geometry
import LensHelp
import Shape
decoratedBlock :: Shape -> Material -> Color -> Float -> [Point2] -> PSType
decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
src/Dodge/Placement/Instance/Tank.hs
+7 -6
View File
@@ -13,24 +13,25 @@ import Geometry
import Shape
tankSquareDec ::
(Float -> Float -> Float -> Color -> Color -> Shape) ->
(Float -> Float -> Float -> Color -> Shape) ->
Color ->
Color ->
Placement
tankSquareDec dec = tankShape (reverse . orderPolygon $ square 20) (dec 20 20 31)
--tankSquareDec dec = tankShape (reverse . orderPolygon $ square 20) (dec 20 20 31)
tankSquareDec dec = tankShape (orderPolygon $ square 20) (dec 20 20 31)
tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
tankShape baseshape facade col col' = sps0 $ decoratedBlock (facade col col') Metal col 31 baseshape
tankShape :: [Point2] -> (Color -> Shape) -> Color -> Color -> Placement
tankShape baseshape facade col col' = sps0 $ decoratedBlock (facade col') Metal col 31 baseshape
roundTank :: Color -> Color -> Placement
roundTank = tankShape (polyCirc 4 20) $
\_ c' -> colorSH c' $ foldMap toprail (take 8 [0, pi / 4 ..])
\c' -> colorSH c' $ foldMap toprail (take 8 [0, pi / 4 ..])
where
toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi / 4) $ V2 0 20)
roundTankCross :: Color -> Color -> Placement
roundTankCross = tankShape (polyCirc 4 20) $
\_ c ->
\c ->
colorSH c $
thinHighBar 31 (V2 20 0) (V2 (-20) 0)
<> thinHighBar 31 (V2 0 20) (V2 0 (-20))
src/Dodge/Placement/TopDecoration.hs
+26 -16
View File
@@ -1,4 +1,12 @@
module Dodge.Placement.TopDecoration where
{-# LANGUAGE LambdaCase #-}
module Dodge.Placement.TopDecoration (
decorationToShape,
fourEmbossDecoration,
midBarDecoration,
squareDecoration,
plusDecoration,
) where
import Color
import Dodge.Data.GenParams
@@ -6,15 +14,15 @@ import Dodge.Room.Foreground
import Geometry
import Shape
decorationToShape :: DecorationShape -> Float -> Float -> Float -> Color -> Color -> Shape
decorationToShape dec = case dec of
decorationToShape :: DecorationShape -> Float -> Float -> Float -> Color -> Shape
decorationToShape = \case
PLUS -> plusDecoration
SQUARE -> squareDecoration
CIRCLE -> circleDecoration
THREELINES -> threeLineDecoration
midBarDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
midBarDecoration w h z _ c =
midBarDecoration :: Float -> Float -> Float -> 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))
@@ -22,24 +30,26 @@ midBarDecoration w h z _ c =
w' = 0.3 * w
embossingR =
colorSH c $
prismPoly Medium Typical
prismPoly
Medium
Typical
[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)]
fourEmbossDecoration :: Float -> Float -> Float -> 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 = upperBoxHalf Large Typical 10 $ rectNSWE (h / 2) (- h / 2) (- w / 2) (w / 2)
plusDecoration :: Float -> Float -> Float -> Color -> Color -> Shape
plusDecoration w h z _ c =
plusDecoration :: Float -> Float -> Float -> 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 =
squareDecoration :: Float -> Float -> Float -> Color -> Shape
squareDecoration w h z col =
colorSH col $
foldMap
f
@@ -53,13 +63,13 @@ squareDecoration w h z _ col =
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 ..])
circleDecoration :: Float -> Float -> Float -> 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 =
threeLineDecoration :: Float -> Float -> Float -> Color -> Shape
threeLineDecoration w h z col =
colorSH col $
foldMap
f
src/Dodge/Room/Corridor.hs
+2 -1
View File
@@ -21,7 +21,8 @@ corridor =
, _rmLinks = lnks'
, --, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
_rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 10]
, _rmPmnts = [spanLightI (V2 0 39.5) (V2 40 39.5)]
--, _rmPmnts = [spanLightI (V2 0 39.5) (V2 40 39.5)]
, _rmPmnts = []
, _rmBound = [rectNSWE 50 30 (-5) 45]
, _rmFloor = Tiled [makeTileFromPoly poly 5]
, _rmRandPSs = [psRandRanges (10, 30) (30, 60) (0, 2 * pi)]
src/Dodge/Room/Tutorial.hs
+2 -1
View File
@@ -49,7 +49,8 @@ tutAnoTree = do
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
--, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
, tToBTree "sdr" . return . cleatOnward <$> tanksPipesRoom
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor