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

Make buttons have shape, expose multiple bugs

Browse Source
This commit is contained in:
justin
2021-09-27 12:28:53 +01:00
parent d9ad55ec50
commit 743c1c878d
19 changed files with 157 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1 -1
View File
@@ -240,7 +240,7 @@ data WorldState
| CrNumAlive Int
deriving (Eq,Ord)
data Button = Button
{ _btPict :: Picture
{ _btPict :: Button -> SPic
, _btPos :: Point2
, _btRot :: Float
, _btEvent :: Button -> World -> World
src/Dodge/Default.hs
+13 -5
View File
@@ -19,7 +19,7 @@ import Dodge.SoundLogic.LoadSound
import Dodge.Picture.Layer
import Geometry
import Picture
--import ShapePicture
import ShapePicture
import Shape
import Control.Lens
@@ -208,14 +208,22 @@ defaultIt = Consumable
, _itHammer = HammerUp
, _itAimStance = LeaveHolstered
}
defaultDrawButton :: Color -> Button -> SPic
defaultDrawButton col bt
| _btState bt == BtOff =
( translateSHz 15 . colorSH col $ upperPrismPoly 5 $ rectNSEW 5 (-5) 10 (-10)
, mempty
)
| otherwise =
( translateSHz 15 . colorSH red $ upperPrismPoly 5 $ rectNSEW (-3) (-5) 10 (-10)
, mempty
)
defaultButton :: Button
defaultButton = Button
{ _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
{ _btPict = defaultDrawButton (dark red)
, _btPos = V2 0 0
, _btRot = 0
, _btEvent = \b w ->
set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
. set (buttons . ix (_btID b) . btState) BtNoLabel
, _btEvent = \b w -> set (buttons . ix (_btID b) . btState) BtNoLabel
. soundStart (LeverSound 0) (_btPos b) click1S Nothing $ w
, _btID = 0
, _btText = "Button"
src/Dodge/Floor.hs
+18 -18
View File
@@ -52,24 +52,24 @@ initialRoomTree = do
[[StartRoom]
,[Corridor]
,[Corridor]
,[SpecificRoom roomCCrits]
,[Corridor]
,[Corridor]
,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
& rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
]++)
]
--,[Corridor]
--,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
-- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
-- ]
,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
& rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
]
,[Corridor]
,[Corridor]
---- ,[SpecificRoom roomCCrits]
---- ,[Corridor]
---- ,[Corridor]
---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
---- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
---- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
---- ]++)
---- ]
---- --,[Corridor]
---- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
---- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
---- -- ]
---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
---- ]
---- ,[Corridor]
---- ,[Corridor]
-- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30]
,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 30 80 200 40)]
,[Corridor]
src/Dodge/GameRoom.hs
+1
View File
@@ -7,6 +7,7 @@ import Geometry
data GameRoom = GameRoom
{ _grViewpoints :: [Point2]
, _grViewpointsEx :: [Point2]
, _grBound :: [Point2]
, _grDir :: Float -- ^ gives direction of room
, _grName :: String
src/Dodge/Layout.hs
+1 -1
View File
@@ -138,7 +138,7 @@ gameRoomsFromRooms = map f
where
f rm = GameRoom
{ _grViewpoints = (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
++ map fst (_rmLinks rm)
, _grViewpointsEx = map fst (_rmLinks rm)
, _grBound = expandPolyByFixed 100 $ orderPolygon $ convexHullSafe $ concat $ _rmBound rm ++ _rmPolys rm
, _grDir = snd . last $ _rmLinks rm
, _grName = _rmName rm
src/Dodge/LevelGen/Switch.hs
+21 -18
View File
@@ -1,11 +1,13 @@
module Dodge.LevelGen.Switch
where
import Dodge.Data
import Dodge.Default
import Dodge.Data.SoundOrigin
import Dodge.SoundLogic
import Dodge.SoundLogic.LoadSound
import Dodge.Picture.Layer
import Picture
import ShapePicture
import Shape
import Geometry
--import Geometry.Data
@@ -15,8 +17,8 @@ makeButton
:: Color
-> (World -> World) -- ^ Effect when pressed
-> Button
makeButton c eff = Button
{ _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
makeButton col eff = Button
{ _btPict = defaultDrawButton col
, _btPos = V2 0 0
, _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
@@ -27,17 +29,28 @@ makeButton c eff = Button
, _btState = BtOff
}
where
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
onPict = setLayer 0 $ onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
turnOn bt = bt {_btState = BtNoLabel, _btEvent = const id}
btpos b w' = _btPos $ _buttons w' IM.! _btID b
drawSwitch :: Color -> Color -> Button -> SPic
drawSwitch col1 col2 bt
| _btState bt == BtOff = flick $ pi/4
| otherwise = flick (negate (pi/4))
where
flick a = ( mconcat
[ colorSH col1 . translateSHz 10 . upperPrismPoly 10 $ rectNSEW (-2) (-5) 10 (-10)
, colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 (0) 2 (-2)
]
, mempty)
makeSwitch
:: Color
:: Color
-> Color
-> (World -> World) -- ^ Switch on effect
-> (World -> World) -- ^ Switch off effect
-> Button
makeSwitch c effOn effOff = Button
{ _btPict = offPict
makeSwitch col1 col2 effOn effOff = Button
{ _btPict = drawSwitch col1 col2
, _btPos = V2 0 0
, _btRot = 0
, _btEvent = flipSwitch
@@ -52,24 +65,14 @@ makeSwitch c effOn effOff = Button
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
_ -> error "Trying to switch a button with no label"
offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon $ map toV2 [(-2,-5),(-10,4),(-6,4),(2,-5)]
]
onPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon $ map toV2 [(-2,-5), (6,4),( 10,4),(2,-5)]
]
turnOn :: Button -> Button
turnOn bt = bt
{ _btState = BtOn
, _btPict = onPict
, _btText = "SWITCH\\"
}
turnOff :: Button -> Button
turnOff bt = bt
{ _btState = BtOff
, _btPict = offPict
, _btText = "SWITCH/"
}
src/Dodge/LevelGen/TriggerDoor.hs
+1 -1
View File
@@ -52,7 +52,7 @@ addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt)
where
bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
bt = (makeSwitch c red openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraphP w
newGraph = pairsToGraph dist newGraphPairs
src/Dodge/LightSources.hs
+59 -7
View File
@@ -5,6 +5,8 @@ module Dodge.LightSources
, colorLightAt
, lampPic
, lampCover
, doubleLampCover
, verticalLampCover
)
where
import Dodge.Data
@@ -72,22 +74,72 @@ lampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = updateLampCover
, _pjUpdate = rotateProp 0.15
, _prDraw = drawLampCover h
}
updateLampCover :: Prop -> World -> World
updateLampCover pr w = w
& props . ix (_pjID pr) . pjRot +~ 0.15
doubleLampCover :: Float -> Prop
doubleLampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawDoubleLampCover h
}
-- on the current (27/9/21) version of shadow stencilling, this glitches
-- slightly when the shadow rotates towards the screen
verticalLampCover :: Float -> Prop
verticalLampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawVerticalLampCover h
}
rotateProp :: Float -> Prop -> World -> World
rotateProp rotAmount pr w = w
& props . ix (_pjID pr) . pjRot +~ rotAmount
drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr =
( translateSHz (h-2.5) . uncurryV translateSHf pos
$ rotateSH a $ mconcat
[ upperPrismPoly 5 $ rectNSEW 6 5 6 (-4)
, upperPrismPoly 5 $ rectNSEW 6 (-4) 6 5
[ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
--, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
, upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
, upperPrismPoly 1 $ [V2 2 2,V2 (-1) 2,V2 2 (-1)]
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr =
( translateSHz (h-2.5) . uncurryV translateSHf pos
$ rotateSH a $ mconcat
[ upperPrismPoly 5 $ rectNSEW 6 5 6 (-6)
, upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
, upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
, upperPrismPoly 1 [V2 0 (1),V2 (-6) (-5),V2 6 (-5)]
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr =
( translateSHz h . uncurryV translateSHf pos
$ rotateSHx a $ mconcat
[
translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
]
, mempty
)
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -93,7 +93,7 @@ crDraw w c = _spPicture $ _crPict c c w
ppDraw :: PressPlate -> Picture
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
btDraw :: Button -> Picture
btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_btPict c)
btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_spPicture $ _btPict c c)
clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (_clPict c c)
src/Dodge/Render/Shape.hs
+4
View File
@@ -15,10 +15,14 @@ worldShape w = _foregroundShape w
<> foldMap (crShape w) (IM.filter (pointIsClose . _crPos) (_creatures w))
<> foldMap (_spShape . floorItemSPic) (IM.filter (pointIsClose . _flItPos) $ _floorItems w)
<> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w)
<> foldMap btShape (IM.filter (pointIsClose . _btPos) $ _buttons w)
where
pointIsClose p = dist camCen p < winSize
winSize = 30 + max (getWindowX w) (getWindowY w)
camCen = _cameraCenter w
btShape :: Button -> Shape
btShape bt = uncurryV translateSHf (_btPos bt) $ rotateSH (_btRot bt) (_spShape $ _btPict bt bt)
crShape :: World -> Creature -> Shape
crShape w c = _spShape $ _crPict c c w
src/Dodge/Room/Airlock.hs
+3 -3
View File
@@ -62,7 +62,7 @@ airlock0 n = defaultRoom
, _rmPS =
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0) 2
,sPS (V2 0 80) 0 $ PutDoubleDoor col cond (V2 1 0) (V2 39 0) 2
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col red
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (V2 (-25) 50) 0 putLamp
@@ -100,7 +100,7 @@ airlock90 n = defaultRoom
]
, _rmPS =
[sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss
,sPS (V2 120 120) (3* pi/4) $ PutButton $ makeSwitch col
,sPS (V2 120 120) (3* pi/4) $ PutButton $ makeSwitch col red
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (V2 60 60) 0 putLamp
@@ -140,7 +140,7 @@ airlockCrystal n = defaultRoom
]
, _rmPS =
[sPS (V2 0 0) 0 $ PutDoor col (not . cond) pss
,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col
,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col red
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,crystalLine (V2 0 70) (V2 40 70)
src/Dodge/Room/Corridor.hs
+2 -2
View File
@@ -17,8 +17,8 @@ corridor = defaultRoom
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS =
[-- sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
sPS (V2 0 0) 0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
[sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
,sPS (V2 0 0) 0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
]
, _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2]
src/Dodge/Room/LongDoor.hs
+5 -1
View File
@@ -15,6 +15,7 @@ import Dodge.LevelGen.Switch
import Dodge.RandomHelp
import Dodge.Creature.Inanimate
import Dodge.Creature
import Dodge.LightSources
import Picture
import Geometry
@@ -44,14 +45,17 @@ twinSlowDoorRoom drID w h x = defaultRoom
, sPS (V2 (negate 25) 5) 0 putLamp
, sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1
, sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1
, sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col
, sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red
(over worldState (M.insert (DoorNumOpen drID) True))
(over worldState (M.insert (DoorNumOpen drID) False))
-- , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
-- , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight
]
, _rmBound = ps
, _rmName = "twinSlowDoorRoom"
}
where
lampHeight = 41
ps =
[rectNSWE h 0 (-w) w
,rectNSWE 20 (-h) (negate x) x
src/Dodge/Room/Procedural.hs
+1 -1
View File
@@ -246,7 +246,7 @@ centerVaultRoom n w h d = do
col = dim $ dim $ bright red
theDoor i =
[ sPS (V2 0 (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) 0) (V2 19 0) 2
, sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col
, sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red
(over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False))
]
src/Dodge/Room/Start.hs
+5 -8
View File
@@ -8,7 +8,7 @@ import Dodge.Room.Placement
import Dodge.Room.Foreground
import Dodge.Layout.Tree.Polymorphic
import Dodge.LevelGen.Data
import Dodge.LightSources
--import Dodge.LightSources
--import Picture
import Geometry.Data
@@ -33,13 +33,10 @@ startRoom = do
<$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0)
$ roomRectAutoLinks w h & rmPS .~
[ fground
--, theLamp
, sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
, sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
, theLamp
--, sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
--, sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
]
)
where
lampHeight = 41
-- where
-- cola = dark . dark . light . light $ light red
-- colb = dark . dark . light . light $ light blue
--lampHeight = 41
src/Dodge/Update/Camera.hs
+7 -4
View File
@@ -147,7 +147,7 @@ autoZoomCam :: World -> World
autoZoomCam w = over cameraZoom changeZoom w
where
camPos = _cameraViewFrom w
wallZoom = farWallDist' camPos w
wallZoom = farWallDist camPos w
idealZoom
| SDL.ButtonRight `S.member` _mouseButtons w
= theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? itAimZoom) wallZoom
@@ -162,14 +162,17 @@ autoZoomCam w = over cameraZoom changeZoom w
zoomOutSpeed = 15
theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
farWallDist' :: Point2 -> World -> Float
farWallDist' p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
farWallDist :: Point2 -> World -> Float
farWallDist p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
where
findMax curMax pout = max curMax $ dist p $ collidePointUpToIndirectMinDist p pout curMax wos
hw = halfWidth w
hh = halfHeight w
winFac = min hw hh
vps = concatMap _grViewpoints grs
vps = concatMap _grViewpoints grs ++ linkvps
linkvps = map extend (concatMap _grViewpointsEx grs)
extend :: Point2 -> Point2
extend outp = p +.+ maxViewDistance *.* safeNormalizeV (outp -.- p)
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
wos = wallsOnScreen w
src/Geometry/Vector3D.hs
+6
View File
@@ -49,6 +49,12 @@ rotate3 a (V3 x y z) = V3 x' y' z
where
(V2 x' y') = rotateV a (V2 x y)
rotate3x :: Float -> Point3 -> Point3
{-# INLINE rotate3x #-}
rotate3x a (V3 x y z) = V3 x y' z'
where
(V2 y' z') = rotateV a (V2 y z)
magV3 :: Point3 -> Float
{-# INLINE magV3 #-}
magV3 (V3 x y z) = sqrt $ x^i + y^i + z^i
src/Shader/Poke.hs
+3
View File
@@ -159,11 +159,14 @@ topPrismEdgeIndices n = concatMap f [0..n-1]
topPrismIndices :: Int -> [Int]
topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
++ concatMap f' [1..n-2] -- triangles on bottom face
-- these should be checked
++ [2*n-2,2*n-1,1
,2*n-2,1,0] -- last side triangle (applies mod 2n)
++ concatMap g [0..n-2] -- other triangles on sides
where
f x = [0,2*x,2*x+2]
f' x = [1,2*x+1,2*x+3]
g x = [2*x,2*x+1,2*x+3
,2*x,2*x+3,2*x+2]
src/Shape.hs
+5
View File
@@ -10,6 +10,7 @@ module Shape
, translateSHz
, translateSHf
, rotateSH
, rotateSHx
, scaleSH
, colorSH
)
@@ -104,6 +105,10 @@ rotateSH :: Float -> Shape -> Shape
{-# INLINE rotateSH #-}
rotateSH a = overPos (rotate3 a)
rotateSHx :: Float -> Shape -> Shape
{-# INLINE rotateSHx #-}
rotateSHx a = overPos (rotate3x a)
scaleSH :: Point3 -> Shape -> Shape
{-# INLINE scaleSH #-}
scaleSH (V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))