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

Compare commits

base: justin/loop:5b95bcbf3bd1afc7fce3f4a5a548ca06ebe511db
Branches Tags
justin/loop:master justin/loop:renameConsole
...
compare: justin/loop:7fcaac2a01c13c1921f7d6985b3ac2b0c8ada898
Branches Tags
justin/loop:master justin/loop:renameConsole

32 Commits
5b95bcbf3b ... 7fcaac2a01

Author SHA1 Message Date
justin 7fcaac2a01 Allow movement when viewing terminals 2025-09-01 23:51:16 +01:00
justin a478ee0a2a Fix sensor fail tline 2025-09-01 23:29:10 +01:00
justin 8398f0b852 Simplify analyser terminal 2025-09-01 23:24:11 +01:00
justin cbcc7e4fd6 Fix autorifle muzzle flash 2025-09-01 20:24:52 +01:00
justin 89c9337822 Allow for more sounds to be playing at once 2025-09-01 20:12:50 +01:00
justin 85591424fd Add debug test 2025-09-01 17:27:58 +01:00
justin 01228ed2f1 Unify debug pictures 2025-09-01 17:22:16 +01:00
justin 6c3c023ed9 Sum attached held items to determine strength effect 2025-09-01 10:26:43 +01:00
justin 291a35f538 Cleanup, add a slight border to ideal camera zoom 2025-08-31 11:47:45 +01:00
justin 2a0e6d1e6e Cleanup 2025-08-27 22:35:33 +01:00
justin 3c2369d979 Cleanup 2025-08-27 22:06:10 +01:00
justin 871d695574 Cleanup 2025-08-27 19:28:56 +01:00
justin dda0526180 Cleanup 2025-08-27 19:22:01 +01:00
justin 40d2d316cb Cleanup 2025-08-27 18:55:25 +01:00
justin 86696deb56 Continue to refactor body/equipment positionings 2025-08-27 14:40:13 +01:00
justin 9d2a2e6730 Work on refactoring positioning relative to creature body 2025-08-27 12:11:01 +01:00
justin 2e6b7a1b41 Add AimStance to creature posture when Aiming 2025-08-27 11:46:41 +01:00
justin 5cb8be1363 Cleanup equipment item function 2025-08-27 11:33:09 +01:00
justin 5280d428a9 Commit before adding AimStance to Aiming Posture 
AMEND: AimStance is also used when AtEase, so this is not a good solution
 2025-08-27 11:26:52 +01:00
justin 5880bd8b8c Cleanup 2025-08-27 11:04:50 +01:00
justin 1ef5534bc2 Cleanup 2025-08-27 01:06:04 +01:00
justin 7581c86d93 Cleanup various equipment/right button code 2025-08-27 00:45:58 +01:00
justin 79a0137d54 Cleanup 2025-08-27 00:34:24 +01:00
justin 06d50ac752 Make equipment indices point to item indices 2025-08-26 23:57:02 +01:00
justin 49efe62910 Commit before modifying crEquipment for item locations 2025-08-26 22:13:40 +01:00
justin e5473d1028 Cleanup 2025-08-26 19:35:19 +01:00
justin 1ebdbdd8ae Cleanup 2025-08-26 18:51:14 +01:00
justin b87c3380b8 Refactor triplet to Selection datatype 2025-08-26 18:13:27 +01:00
justin 9034c409e1 Flatten HUDElement 2025-08-26 16:46:02 +01:00
justin 596880f76a Cleanup 2025-08-26 16:19:49 +01:00
justin f7fd747a7c Allow drag selecting outside of the selection section 
Does not yet work outside of any selection section.
Need to think about what widths are acceptable to allow for selection.
 2025-08-26 12:42:48 +01:00
justin 004c4d1950 Commit before removing "above/below" checks on inventory dragging 
I don't think these actually do anything
EDIT: they are actually necessary
 2025-08-26 11:38:46 +01:00
110 changed files with 1919 additions and 2629 deletions
Expand all files Collapse all files
.gitignore
+1
View File
@@ -4,3 +4,4 @@
loop.cabal
*.lock
keys.json
log/*
appDodge/Main.hs
+1 -1
View File
@@ -75,7 +75,7 @@ winConfig x y winpos =
theCleanup :: Universe -> IO ()
theCleanup uv = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData uv)
firstWorldLoad :: Configuration -> IO Universe
firstWorldLoad :: Config -> IO Universe
firstWorldLoad theConfig = do
SDL.cursorVisible $= False
pdata <- doPreload >>= applyWorldConfig theConfig
data/dodge.config.json
+3 -5
View File
@@ -1,8 +1,6 @@
{
"_debug_booleans": [
"Show_ms_frame",
"Mouse_position",
"Collision_test"
"Show_ms_frame"
],
"_debug_view_clip_bounds": "NoRoomClipBoundaries",
"_gameplay_rotate_to_wall": true,
@@ -14,11 +12,11 @@
"_graphics_num_shadow_casters": "NumShadowCasters20",
"_graphics_shadow_rendering": "GeoObjShads",
"_graphics_shadow_size": "Typical",
"_graphics_world_resolution": "QuarterRes",
"_graphics_world_resolution": "HalfRes",
"_volume_master": 1,
"_volume_music": 0,
"_volume_sound": 1,
"_windowPosX": 0,
"_windowPosX": 800,
"_windowPosY": 29,
"_windowX": 800,
"_windowY": 835
log/aGeneratedRoomLayout
+21 -143
View File
@@ -2,162 +2,40 @@ Seed: 7114951007332849727
Room layout (compact):
0,1,2,3,4,5,6
|
+- 7,8,9,10,11,12,13,14,15,16,17,18,19,20,21
| |
| +- 22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46
| | |
| | +- 47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64
| | |
| | 65,66
| |
| 67,68,69
+- 7,8
|
70,71,72
+- 9,10
|
11,12,13,14
Layout with room names:
rezBox-0
Corridor-0
|
autoDoor-1
6gon-1
|
rectPillars-2
defaultRoom-2
|
autoDoor-3
autoRect-3
|
Corridor-4
autoDoor-4
|
autoDoor-5
Corridor-5
|
ElecautoRect-6
doorToggle-6gon-6
|
+- triggerDoorRoom-7
| |
| autoDoor-8
| |
| autoDoor-9
| |
| Corridor-10
| |
| autoDoor-11
| |
| 8gon-12
| |
| triggerDoorRoom-13
| |
| autoDoor-14
| |
| autoDoor-15
| |
| Corridor-16
| |
| autoRect-17
| |
| autoDoor-18
| |
| Corridor-19
| |
| autoDoor-20
| |
| 6gon-21
| |
| +- triggerDoorRoom-22
| | |
| | autoDoor-23
| | |
| | autoDoor-24
| | |
| | Corridor-25
| | |
| | autoDoor-26
| | |
| | doorToggle-8gon-27
| | |
| | triggerDoorRoom-28
| | |
| | autoDoor-29
| | |
| | autoDoor-30
| | |
| | Corridor-31
| | |
| | autoRect-32
| | |
| | autoDoor-33
| | |
| | Corridor-34
| | |
| | autoDoor-35
| | |
| | Corridor-36
| | |
| | 8gon-37
| | |
| | triggerDoorRoom-38
| | |
| | autoDoor-39
| | |
| | autoDoor-40
| | |
| | Corridor-41
| | |
| | tanksRoom-42
| | |
| | autoDoor-43
| | |
| | Corridor-44
| | |
| | autoDoor-45
| | |
| | 8gon-46
| | |
| | +- triggerDoorRoom-47
| | | |
| | | autoDoor-48
| | | |
| | | autoDoor-49
| | | |
| | | Corridor-50
| | | |
| | | autoRect-51
| | | |
| | | defaultRoom-52
| | | |
| | | autoRect-53
| | | |
| | | defaultRoom-54
| | | |
| | | autoRect-55
| | | |
| | | autoDoor-56
| | | |
| | | Corridor-57
| | | |
| | | autoDoor-58
| | | |
| | | 8gon-59
| | | |
| | | triggerDoorRoom-60
| | | |
| | | autoDoor-61
| | | |
| | | autoDoor-62
| | | |
| | | Corridor-63
| | | |
| | | defaultRoom-64
| | |
| | autoDoor-65
| | |
| | Corridor-66
| |
| autoDoor-67
| |
| Corridor-68
| |
| autoRect-69
| autoRect-8
|
autoDoor-70
+- triggerDoorRoom-9
| |
| autoRect-10
|
Corridor-71
Corridor-11
|
defaultRoom-72
6gon-12
|
defaultRoom-13
|
autoRect-14
log/attemptedSeeds
+1 -1
View File
@@ -1,4 +1,4 @@
Generating level with seed 7114951007332849727
After 1 attempt(s), Successful generation of level with seed 7114951007332849727
73 rooms in total
15 rooms in total
log/treeCluster
+28 -248
View File
@@ -1,269 +1,49 @@
Seed: 7114951007332849727
0:startThenWeaponRoom
0:teststart
|
1:corDoor
1:TutDrop
|
2:PassthroughLockKeyLists-HELD {_ibtHeld = SPARKGUN}
2:corDoor
|
3:corDoor
3:DoorTest
|
4:lasSensorTurretTest
|
5:corDoor
|
6:anRoom
|
7:corDoor
|
8:PassthroughLockKeyLists-HELD {_ibtHeld = KEYCARD 0}
|
9:corDoor
|
10:warningRooms
|
11:corDoor
|
12:chaseCrit+armourChaseCrit rectRoom
|
13:corDoor
|
14:healthTest
|
15:corDoor
|
16:empty tanksRoom
|
17:corDoor
|
18:PassthroughLockKeyLists-HELD {_ibtHeld = RLAUNCHER}
|
19:corDoor
|
20:shootingRange
|
21:corDoor
|
22:lasSensorTurretTest
|
23:corDoor
|
24:randomFourCornerRoom
4:TutDrop
0:0:startThenWeaponRoom
0:0:teststart
0:0:0:Corridor
1:0:TutDrop
1:0:0:6gon
|
0:1:weaponBetweenPillars_BANGSTICK4
0:0:0:rezBox'
0:0:0:0:rezBox
1:0:1:defaultRoom
|
0:0:0:1:autoDoor
1:0:2:autoRect
0:1:0:rectPillars
2:0:corDoor
1:0:corDoor
1:0:0:autoDoor
2:0:0:autoDoor
|
1:0:1:Corridor
2:0:1:Corridor
2:0:PassthroughLockKeyLists-HELD {_ibtHeld = SPARKGUN}
3:0:DoorTest
2:0:0:RassThroughLockKeyLists
3:0:0:doorToggle-6gon
|
2:0:1:roomsContaining chaseCritchaseCritTRANSFORMERCANCAN
2:0:0:0:sensorRoomRunPast
2:0:0:0:0:autoDoor
|
2:0:0:0:1:ElecautoRect
|
+- 2:0:0:0:2:triggerDoorRoom
+- 3:0:1:triggerDoorRoom
| |
| 2:0:0:0:3:autoDoor
| 3:0:2:autoRect
|
2:0:0:0:4:autoDoor
|
2:0:0:0:5:Corridor
2:0:1:0:defaultRoom
3:0:corDoor
3:0:0:autoDoor
|
3:0:1:Corridor
4:0:lasSensorTurretTest
4:0:0:autoDoor
|
4:0:1:8gon
|
4:0:2:triggerDoorRoom
|
4:0:3:autoDoor
5:0:corDoor
5:0:0:autoDoor
|
5:0:1:Corridor
6:0:anRoom
6:0:0:autoRect
7:0:corDoor
7:0:0:autoDoor
|
7:0:1:Corridor
8:0:PassthroughLockKeyLists-HELD {_ibtHeld = KEYCARD 0}
8:0:0:RassThroughLockKeyLists
|
8:0:1:roomsContaining DEFAULTCRNAMEchaseCritchaseCritKEYCARD 0
8:0:0:0:keyCardRoomRunPast
8:0:0:0:0:autoDoor
|
8:0:0:0:1:6gon
|
+- 8:0:0:0:2:triggerDoorRoom
+- 3:0:3:triggerDoorRoom
| |
| 8:0:0:0:3:autoDoor
| 3:0:4:autoRect
|
8:0:0:0:4:autoDoor
3:0:5:Corridor
4:0:6gon
|
8:0:0:0:5:Corridor
8:0:1:0:autoRect
9:0:corDoor
9:0:0:autoDoor
4:1:defaultRoom
|
9:0:1:Corridor
10:0:warningRooms
10:0:0:autoDoor
|
10:0:1:doorToggle-8gon
|
10:0:2:triggerDoorRoom
|
10:0:3:autoDoor
11:0:corDoor
11:0:0:autoDoor
|
11:0:1:Corridor
12:0:chaseCrit+armourChaseCrit rectRoom
12:0:0:autoRect
13:0:corDoor
13:0:0:autoDoor
|
13:0:1:Corridor
14:0:healthTest
14:0:0:autoDoor
|
14:0:1:Corridor
|
14:0:2:8gon
|
14:0:3:triggerDoorRoom
|
14:0:4:autoDoor
15:0:corDoor
15:0:0:autoDoor
|
15:0:1:Corridor
16:0:empty tanksRoom
16:0:0:tanksRoom
17:0:corDoor
17:0:0:autoDoor
|
17:0:1:Corridor
18:0:PassthroughLockKeyLists-HELD {_ibtHeld = RLAUNCHER}
18:0:0:RassThroughLockKeyLists
|
18:0:1:roomsContaining chaseCritchaseCritTUBETUBEHARDWARE
18:0:0:0:lasCenSensEdge
18:0:0:0:0:autoDoor
|
18:0:0:0:1:8gon
|
+- 18:0:0:0:2:triggerDoorRoom
| |
| 18:0:0:0:3:autoDoor
|
18:0:0:0:4:autoDoor
|
18:0:0:0:5:Corridor
18:0:1:0:autoRect
19:0:corDoor
19:0:0:autoDoor
|
19:0:1:Corridor
20:0:shootingRange
20:0:0:autoRect
|
20:0:1:defaultRoom
|
20:0:2:autoRect
|
20:0:3:defaultRoom
|
20:0:4:autoRect
21:0:corDoor
21:0:0:autoDoor
|
21:0:1:Corridor
22:0:lasSensorTurretTest
22:0:0:autoDoor
|
22:0:1:8gon
|
22:0:2:triggerDoorRoom
|
22:0:3:autoDoor
23:0:corDoor
23:0:0:autoDoor
|
23:0:1:Corridor
24:0:defaultRoom
4:2:autoRect
saveSlot/0
+1 -1
View File
File diff suppressed because one or more lines are too long
saveSlot/LevelStart0
+1 -1
View File
File diff suppressed because one or more lines are too long
src/Dodge/Annotation.hs
+1 -1
View File
@@ -30,7 +30,7 @@ annoToRoomTree an = case an of
i <- nextLayoutInt
(functionlockroom, randomitemidentity) <- takeOne ls
lr <- zoom lyGen $ functionlockroom i
ii <- zoom lyGen $ randomitemidentity
ii <- zoom lyGen randomitemidentity
keyroom <- zoom lyGen . fromJust $ lookup ii ks
return $
MTree
src/Dodge/AssignHotkey.hs
+3 -5
View File
@@ -1,18 +1,16 @@
module Dodge.AssignHotkey (assignHotkey) where
import Dodge.Data.Equipment.Misc
import Control.Lens
import Data.Maybe
import Dodge.Data.Equipment.Misc
import Dodge.Data.World
import NewInt
-- it is not obvious to me whether hotkeys should belong to LWorld, CWorld or
-- World
assignHotkey :: NewInt ItmInt -> Hotkey -> LWorld -> LWorld
assignHotkey i hk lw = lw
assignHotkey i hk lw =
lw
& handleoldposition
& hotkeys . at hk ?~ i
-- & imHotkeys . unNIntMap . at itid ?~ hk
& imHotkeys . at i ?~ hk
where
handleoldposition = fromMaybe id $ do
src/Dodge/Base/Coordinate.hs
+1 -1
View File
@@ -12,7 +12,7 @@ import Dodge.Data.Input
import Geometry
---- | Transform coordinates from world position to screen coordinates.
--worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
--worldPosToScreenNorm :: Config -> World -> Point2 -> Point2
--worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
-- where
-- doTranslate p = p -.- (w ^. cWorld . lWorld . wCam . cwcCenter)
src/Dodge/Base/Window.hs
+5 -5
View File
@@ -14,7 +14,7 @@ import Dodge.Data.Config
import Geometry
-- | A box covering the screen in world coordinates
screenPolygon :: Configuration -> Camera -> [Point2]
screenPolygon :: Config -> Camera -> [Point2]
screenPolygon cfig w = map (scTran . scRot . scZoom) $ screenBox cfig
where
scRot = rotateV (w ^. camRot)
@@ -29,7 +29,7 @@ screenPolygonBord ::
Float ->
-- | Y border
Float ->
Configuration ->
Config ->
Camera ->
[Point2]
screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br]
@@ -45,16 +45,16 @@ screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br]
br = theTransform (V2 hw (- hh))
bl = theTransform (V2 (- hw) (- hh))
halfWidth, halfHeight :: Configuration -> Float
halfWidth, halfHeight :: Config -> Float
halfWidth = (0.5 *) . windowXFloat
halfHeight = (0.5 *) . windowYFloat
-- | A box of the size of the screen in screen centered coordinates
screenBox :: Configuration -> [Point2]
screenBox :: Config -> [Point2]
screenBox w = rectNSWE hh (- hh) (- hw) hw
where
hw = halfWidth w
hh = halfHeight w
pointIsOnScreen :: Configuration -> Camera -> Point2 -> Bool
pointIsOnScreen :: Config -> Camera -> Point2 -> Bool
pointIsOnScreen cfig w p = pointInPolygon p $ screenPolygon cfig w
src/Dodge/Config/Load.hs
+1 -1
View File
@@ -6,7 +6,7 @@ import Data.Aeson
import Dodge.Data.Config
import System.Directory
loadDodgeConfig :: IO Configuration
loadDodgeConfig :: IO Config
loadDodgeConfig = do
fExists <- doesFileExist "data/dodge.config.json"
if fExists
src/Dodge/Config/Update.hs
+3 -3
View File
@@ -17,7 +17,7 @@ import Sound
{- |
Write the current world configuration to disk as a json file.
-}
saveConfig :: Configuration -> (a -> IO a) -> a -> IO a
saveConfig :: Config -> (a -> IO a) -> a -> IO a
saveConfig cfig f x = do
-- putStrLn "Saving config to data/dodge.config.json"
BS.writeFile "data/dodge.config.json" $
@@ -27,7 +27,7 @@ saveConfig cfig f x = do
{- |
Apply the volume settings from the world configuration to the running game.
-}
setVol :: Configuration -> IO ()
setVol :: Config -> IO ()
setVol cfig = do
setSoundVolume (_volume_master cfig * _volume_sound cfig)
setMusicVolume (_volume_master cfig * _volume_music cfig)
@@ -36,7 +36,7 @@ setVol cfig = do
Apply /all/ of the values in the world configuration to the running game.
-}
applyWorldConfig ::
Configuration ->
Config ->
PreloadData ->
IO PreloadData
applyWorldConfig cfig pdata = do
src/Dodge/Corpse/Make.hs
+4 -5
View File
@@ -9,10 +9,9 @@ import Dodge.Data.Creature
import Geometry
import Shape
import ShapePicture
import qualified Data.IntMap.Strict as IM
makeCorpse :: IM.IntMap Item -> Creature -> Corpse
makeCorpse m cr =
makeCorpse :: Creature -> Corpse
makeCorpse cr =
defaultCorpse
& cpPos .~ _crPos cr
& cpDir .~ _crDir cr
@@ -20,8 +19,8 @@ makeCorpse m cr =
.~ noPic
( scaleSH (V3 crsize crsize crsize) $
mconcat
[ colorSH (_skinHead cskin) $ deadScalp m cr
, colorSH (_skinUpper cskin) $ deadUpperBody m cr
[ colorSH (_skinHead cskin) $ deadScalp cr
, colorSH (_skinUpper cskin) $ deadUpperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
]
)
src/Dodge/Creature.hs
+21 -20
View File
@@ -110,9 +110,9 @@ startInvList = []
startInventory :: IM.IntMap Item
startInventory = IM.fromList $ zip [0 ..] startInvList
inventoryX :: Char -> [Item]
inventoryX :: String -> [Item]
inventoryX c = case c of
'A' ->
"A" ->
[introScan t | t <- [minBound..maxBound]] <>
[ flameThrower
, fuelPack
@@ -122,7 +122,7 @@ inventoryX c = case c of
, unigate
, bingate
]
'B' ->
"B" ->
[ wristArmour
, wristArmour
, volleyGun 5
@@ -146,15 +146,16 @@ inventoryX c = case c of
, makeTypeCraftNum 2 PIPE
, makeTypeCraftNum 1 CREATURESENSOR
]
'C' -> map makeTypeCraft [minBound..maxBound]
'D' ->
"BB" -> [ wristArmour , wristArmour]
"C" -> map makeTypeCraft [minBound..maxBound]
"D" ->
[ blinker
, unsafeBlinker
, pulseChecker
, detector WALLDETECTOR
, battery
]
'E' -> [alteRifle
"E" -> [alteRifle
, tinMag
, tinMag
] <>
@@ -165,7 +166,7 @@ inventoryX c = case c of
, makeTypeCraftNum 1 STEELDRUM
, makeTypeCraftNum 1 MOTOR
]
'F' -> fold
"F" -> fold
[ makeTypeCraftNum 3 PIPE
, makeTypeCraftNum 3 TUBE
, makeTypeCraftNum 3 HARDWARE
@@ -182,7 +183,7 @@ inventoryX c = case c of
, makeTypeCraftNum 3 LIGHTER
-- , makeTypeCraftNum 5 (ENERGYBALLCRAFT IncBall)
]
'G' ->
"G" ->
[ autoPistol
, tinMag
, pistol
@@ -196,19 +197,19 @@ inventoryX c = case c of
-- , makeTypeCraftNum 5 (BULBODYCRAFT BounceBullet)
-- , makeTypeCraftNum 5 (BULBODYCRAFT PenetrateBullet)
]
'H' -> [shatterGun]
'I' ->
"H" -> [shatterGun]
"I" ->
[ makeTypeCraft HARDDRIVE
, makeTypeCraft RAM
] <> fold
[ makeTypeCraftNum 2 MICROCHIP
]
'J' ->
"J" ->
[ laser
, battery
--, dualBeam
] <> makeTypeCraftNum 10 TRANSFORMER
'K' ->
"K" ->
[ autoRifle
, tinMag
] <> fold
@@ -221,14 +222,14 @@ inventoryX c = case c of
, makeTypeCraftNum 1 SOUNDSENSOR
, makeTypeCraftNum 1 HEATSENSOR
]
'L' -> [burstRifle
"L" -> [burstRifle
,tinMag
, bulletSynthesizer
, battery
]
'M' -> stackedInventory
'N' -> [zoomScope,laser,battery, sniperRifle, tinMag]
'O' -> [ rLauncherX 2
"M" -> stackedInventory
"N" -> [zoomScope,laser,battery, sniperRifle, tinMag]
"O" -> [ rLauncherX 2
, shellMag
, shellMag
, rLauncherX 3
@@ -238,9 +239,9 @@ inventoryX c = case c of
, rifle
, shellMag
]
'P' -> [burstRifle , tinMag, bulletSynthesizer, battery]
'T' -> testInventory
'U' ->
"P" -> [burstRifle , tinMag, bulletSynthesizer, battery]
"T" -> testInventory
"U" ->
[targetingScope tt | tt <- [minBound .. maxBound]]
<>
[ gyroscope
@@ -266,7 +267,7 @@ inventoryX c = case c of
, stickyMod
]
<> [shellModule p | p <- [minBound .. maxBound]]
'V' ->
"V" ->
[targetingScope tt | tt <- [minBound .. maxBound]]
<>
[ battery
src/Dodge/Creature/Action.hs
+6 -5
View File
@@ -168,15 +168,16 @@ dropExcept :: Creature -> Int -> World -> World
dropExcept cr invid w =
foldr (dropItem cr) w . IM.keys $
-- invid `IM.delete` _crInv cr
invid `IM.delete` (_unNIntMap $ _crInv cr)
invid `IM.delete` _unNIntMap (_crInv cr)
-- why not a cid (Int)?
dropItem :: Creature -> Int -> World -> World
dropItem cr invid w' =
doanyitemdropeffect
. maybeshiftseldown
. rmInvItem (_crID cr) (NInt invid)
. copyItemToFloor (_crPos cr) itm -- . mayberemoveequip
. rmInvItem (_crID cr) (NInt invid) -- it is important
-- to do this before copying the item to the floor!
. soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing
$ w'
where
@@ -188,8 +189,8 @@ dropItem cr invid w' =
itid <- cr ^? crInv . ix (NInt invid)
w' ^? cWorld . lWorld . items . ix itid
maybeshiftseldown w = fromMaybe w $ do
3 <- w ^? hud . hudElement . diSelection . _Just . _1
return $ w & hud . hudElement . diSelection . _Just . _2 +~ 1
3 <- w ^? hud . diSelection . _Just . slSec
return $ w & hud . diSelection . _Just . slInt +~ 1
-- | Get your creature to drop the item under the cursor.
youDropItem :: World -> World
@@ -200,7 +201,7 @@ youDropItem w = fromMaybe w $ do
--guard $ not $ _crInvLock cr
guard $ not $ w ^. cWorld . lWorld . lInvLock
return $ case cr ^. crStance . posture of
Aiming -> throwItem w
Aiming {} -> throwItem w
AtEase -> dropItem cr curpos w
where
cr = you w
src/Dodge/Creature/ArmourChase.hs
+3 -3
View File
@@ -3,8 +3,8 @@ module Dodge.Creature.ArmourChase (
flockArmourChaseCrit,
) where
import Dodge.Data.Equipment.Misc
import Control.Lens
--import Dodge.Data.Equipment.Misc
--import Control.Lens
import Dodge.Creature.ChaseCrit
import Dodge.Data.Creature
import Dodge.Default
@@ -43,4 +43,4 @@ armourChaseCrit =
-- ]
-- , _crMvType = defaultChaseMvType{_mvTurnRad = FloatConst 0.05}
}
& crEquipment . at OnChest ?~ 0
-- & crEquipment . at OnChest ?~ 0
src/Dodge/Creature/HandPos.hs
+49 -56
View File
@@ -1,22 +1,18 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Creature.HandPos (
equipSitePQ,
translatePointToLeftHand,
translatePointToRightHand,
translatePointToHead,
translateToLeftWrist,
translateToRightWrist,
translateToLeftLeg,
translateToRightLeg,
translateToHead,
translateToChest,
translateToLeftHand,
translateToRightHand,
backPQ,
headPQ,
translateToES,
) where
--import Dodge.Data.Equipment.Misc
import qualified Data.IntMap.Strict as IM
import Dodge.Data.Equipment.Misc
import qualified Quaternion as Q
import Control.Lens
import Dodge.Creature.Test
@@ -24,22 +20,27 @@ import Dodge.Data.Creature
import Geometry
import ShapePicture
translatePointToRightHand :: IM.IntMap Item -> Creature -> Point3 -> Point3
translatePointToRightHand m cr p = fst (rightHandPQ m cr `Q.comp` (p,Q.qID))
translateToES :: Creature -> EquipSite -> Point3 -> Point3
translateToES cr es p = fst (equipSitePQ es cr `Q.comp` (p,Q.qID))
--equipSitePQ :: EquipSite -> IM.IntMap Item -> Creature -> Point3Q
--equipSitePQ = \case
-- OnRightWrist -> rightHandPQ
-- OnLeftWrist -> leftHandPQ
-- OnBack -> backPQ
-- OnChest -> chestPQ
-- _ -> undefined
equipSitePQ :: EquipSite -> Creature -> Point3Q
equipSitePQ = \case
OnLeftWrist -> leftWristPQ
OnRightWrist -> rightWristPQ
OnHead -> headPQ
OnChest -> chestPQ
OnBack -> backPQ
OnLeftLeg -> leftLegPQ
OnRightLeg -> rightLegPQ
rightHandPQ :: IM.IntMap Item -> Creature -> Point3Q
rightHandPQ m cr
| oneH m cr = (V3 11 (-3) 20, Q.qID)
| twists m cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0,Q.qID)
| twoFlat m cr = (V3 4 (-8) 10, Q.qID)
translatePointToRightHand :: Creature -> Point3 -> Point3
translatePointToRightHand cr p = fst (rightHandPQ cr `Q.comp` (p,Q.qID))
rightHandPQ :: Creature -> Point3Q
rightHandPQ cr
| oneH cr = (V3 11 (-3) 20, Q.qID)
| twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0,Q.qID)
| twoFlat cr = (V3 4 (-8) 10, Q.qID)
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> (V3 (- f sa) (- off) 10, Q.qID)
Just (Walking sa RightForward) -> (V3 (- g sa) (- off) 10, Q.qID)
@@ -50,18 +51,17 @@ rightHandPQ m cr
f i = negate 2 + negate 6 * (sLen - i) / sLen
g i = negate 2 + negate 6 * i / sLen
translateToRightHand :: IM.IntMap Item -> Creature -> SPic -> SPic
translateToRightHand m = overPosSP . translatePointToRightHand m
translateToRightHand :: Creature -> SPic -> SPic
translateToRightHand = overPosSP . translatePointToRightHand
translateToRightWrist :: IM.IntMap Item -> Creature -> SPic -> SPic
translateToRightWrist m cr = overPosSP
(\p -> fst $ rightHandPQ m cr `Q.comp` (V3 0 (-4) (-4)+p, Q.qID))
rightWristPQ :: Creature -> Point3Q
rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qID)
leftHandPQ :: IM.IntMap Item -> Creature -> Point3Q
leftHandPQ m cr
| oneH m cr = (V3 0 off 10, Q.qz 0.4)
| twists m cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
| twoFlat m cr = (V3 4 8 10, Q.qID)
leftHandPQ :: Creature -> Point3Q
leftHandPQ cr
| oneH cr = (V3 0 off 10, Q.qz 0.4)
| twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
| twoFlat cr = (V3 4 8 10, Q.qID)
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> (V3 (- f sa) off 10 , Q.qID)
Just (Walking sa LeftForward) -> (V3 (- g sa) off 10 , Q.qID)
@@ -72,15 +72,14 @@ leftHandPQ m cr
f i = negate 2 + negate 6 * (sLen - i) / sLen
g i = negate 2 + negate 6 * i / sLen
translatePointToLeftHand :: IM.IntMap Item -> Creature -> Point3 -> Point3
translatePointToLeftHand m cr p = fst (leftHandPQ m cr `Q.comp` (p,Q.qID))
translatePointToLeftHand :: Creature -> Point3 -> Point3
translatePointToLeftHand cr p = fst (leftHandPQ cr `Q.comp` (p,Q.qID))
translateToLeftHand :: IM.IntMap Item -> Creature -> SPic -> SPic
translateToLeftHand m = overPosSP . translatePointToLeftHand m
translateToLeftHand :: Creature -> SPic -> SPic
translateToLeftHand = overPosSP . translatePointToLeftHand
translateToLeftWrist :: IM.IntMap Item -> Creature -> SPic -> SPic
translateToLeftWrist m cr = overPosSP
(\p -> fst $ leftHandPQ m cr `Q.comp` (V3 0 4 (-4)+p, Q.qID))
leftWristPQ :: Creature -> Point3Q
leftWristPQ cr = leftHandPQ cr `Q.comp` (V3 0 4 (-4), Q.qID)
leftLegPQ :: Creature -> Point3Q
leftLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
@@ -113,26 +112,20 @@ rightLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
translateToRightLeg :: Creature -> SPic -> SPic
translateToRightLeg cr = overPosSP (\p -> fst (rightLegPQ cr `Q.comp` (p,Q.qID)))
translateToHead :: IM.IntMap Item -> Creature -> SPic -> SPic
translateToHead m cr = overPosSP (\p -> fst (headPQ m cr `Q.comp` (p,Q.qID)))
headPQ :: IM.IntMap Item -> Creature -> Point3Q
headPQ m cr
| twists m cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
| oneH m cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
headPQ :: Creature -> Point3Q
headPQ cr
| twists cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
| oneH cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
| otherwise = (V3 2.5 0 20, Q.qID)
translatePointToHead :: IM.IntMap Item -> Creature -> Point3 -> Point3
translatePointToHead m cr p = fst (headPQ m cr `Q.comp` (p,Q.qID))
--translatePointToHead :: IM.IntMap Item -> Creature -> Point3 -> Point3
--translatePointToHead m cr p = fst (headPQ cr `Q.comp` (p,Q.qID))
chestPQ :: IM.IntMap Item -> Creature -> Point3Q
chestPQ m cr = backPQ m cr `Q.comp` (0,Q.qz pi)
chestPQ :: Creature -> Point3Q
chestPQ cr = backPQ cr `Q.comp` (0,Q.qz pi)
translateToChest :: IM.IntMap Item -> Creature -> SPic -> SPic
translateToChest m cr = overPosSP (\p -> fst $ chestPQ m cr `Q.comp` (p,Q.qID))
backPQ :: IM.IntMap Item -> Creature -> Point3Q
backPQ m cr
| oneH m cr = (V3 0 0 10, Q.qz 0.5)
| twists m cr = (V3 0 3 10, Q.qz (-1.5))
backPQ :: Creature -> Point3Q
backPQ cr
| oneH cr = (V3 0 0 10, Q.qz 0.5)
| twists cr = (V3 0 3 10, Q.qz (-1.5))
| otherwise = (V3 0 0 10, Q.qz 0)
src/Dodge/Creature/Impulse/UseItem.hs
+28 -31
View File
@@ -19,7 +19,8 @@ import Dodge.Item.Location
useItem :: Int -> Int -> World -> Maybe World
useItem invid pt w = fmap (worldEventFlags . at InventoryChange ?~ ()) $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0
itmloc <- invIndents (fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ _crInv cr) ^? ix invid . _2
itmloc <- invIndents ((\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr)
^? ix invid . _2
useItemLoc cr itmloc pt w
useItemLoc :: Creature -> LocationDT OItem -> Int -> World -> Maybe World
@@ -44,8 +45,8 @@ useItemLoc cr loc pt w
return $ w & pointerToItem itm . itUse . useToggle .~ not b
| isJust $ itm ^? itType . ibtEquip
, pt == 0
, Just invid' <- itm ^? itLocation . ilInvID =
return $ toggleEquipmentAt invid' cr w
, Just invid <- itm ^? itLocation . ilInvID =
return $ toggleEquipmentAt invid cr w
| otherwise = (\loc' -> useItemLoc cr loc' pt w) =<< locUp' loc
where
aimuse
@@ -64,53 +65,49 @@ activateDetonator det = fromMaybe id $ do
return $ cWorld . lWorld . projectiles . ix pjid . pjTimer .~ 0
toggleEquipmentAt :: NewInt InvInt -> Creature -> World -> World
toggleEquipmentAt invid cr w = case getEquipmentAllocation invid w of
toggleEquipmentAt invid cr w = case equipmentDesignation invid w of
DoNotMoveEquipment -> w
PutOnEquipment{_allocNewPos = newp} ->
w
& crpoint . crEquipment . at newp ?~ invid
& toequipment . at newp ?~ NInt itid
& toitems . ix itid . itLocation . ilEquipSite ?~ newp
& onequip itm cr
& effectOnEquip itm cr
MoveEquipment{_allocNewPos = newp, _allocOldPos = oldp} ->
w
& crpoint . crEquipment . at newp ?~ invid
& crpoint . crEquipment . at oldp .~ Nothing
& toequipment . at newp ?~ NInt itid
& toequipment . at oldp .~ Nothing
& toitems . ix itid . itLocation . ilEquipSite ?~ newp
SwapEquipment{_allocNewPos = newp, _allocOldPos = oldp, _allocSwapID = sid} ->
w
& crpoint . crEquipment . at newp ?~ invid
& crpoint . crEquipment . at oldp ?~ sid
& toequipment . at newp ?~ NInt itid
& toequipment . at oldp ?~ sid
& toitems . ix itid . itLocation . ilEquipSite ?~ newp
& toitems . ix (invidtoitid sid) . itLocation . ilEquipSite ?~ oldp
& toitems . ix (_unNInt sid) . itLocation . ilEquipSite ?~ oldp
ReplaceEquipment{_allocNewPos = newp, _allocRemoveID = rid} ->
w
& crpoint . crEquipment . at newp ?~ invid
& toequipment . at newp ?~ NInt itid
& toitems . ix itid . itLocation . ilEquipSite ?~ newp
& toitems . ix (invidtoitid rid) . itLocation . ilEquipSite .~ Nothing
& onremove (itmat rid) cr
& onequip itm cr
& toitems . ix (_unNInt rid) . itLocation . ilEquipSite .~ Nothing
& effectOnRemove (itmat rid) cr
& effectOnEquip itm cr
RemoveEquipment{_allocOldPos = oldp} ->
w
& crpoint . crEquipment . at oldp .~ Nothing
& toequipment . at oldp .~ Nothing
& toitems . ix itid . itLocation . ilEquipSite .~ Nothing
& onremove itm cr
& effectOnRemove itm cr
where
invidtoitid :: NewInt InvInt -> Int
invidtoitid i = cr ^?! crInv . ix i -- _crInv cr IM.! i
toitems = cWorld . lWorld . items
itid = invidtoitid invid
crpoint = cWorld . lWorld . creatures . ix (_crID cr)
itmat i = w ^?! cWorld . lWorld . items . ix (invidtoitid i)
itm = itmat invid
onequip itm' = effectOnEquip itm'
onremove itm' = effectOnRemove itm'
itid = cr ^?! crInv . ix invid
toequipment = cWorld . lWorld . creatures . ix (_crID cr) . crEquipment
itmat i = w ^?! cWorld . lWorld . items . ix (_unNInt i)
itm = w ^?! cWorld . lWorld . items . ix itid
toggleExamineInv :: World -> World
toggleExamineInv w = case w ^? hud . hudElement . subInventory of
Just ExamineInventory{} -> w & hud . hudElement . subInventory .~ NoSubInventory
_ -> w & hud . hudElement . subInventory .~ ExamineInventory
toggleExamineInv w = case w ^? hud . subInventory of
Just ExamineInventory{} -> w & hud . subInventory .~ NoSubInventory
_ -> w & hud . subInventory .~ ExamineInventory
toggleMapperInv :: Item -> World -> World
toggleMapperInv itm w = case w ^? hud . hudElement . subInventory of
Just MapperInventory{} -> w & hud . hudElement . subInventory .~ NoSubInventory
_ -> w & hud . hudElement . subInventory .~ MapperInventory 0 1 (_itID itm)
toggleMapperInv itm w = case w ^? hud . subInventory of
Just MapperInventory{} -> w & hud . subInventory .~ NoSubInventory
_ -> w & hud . subInventory .~ MapperInventory 0 1 (_itID itm)
src/Dodge/Creature/Picture.hs
+21 -28
View File
@@ -9,6 +9,7 @@ module Dodge.Creature.Picture (
deadFeet,
) where
import Dodge.Data.Equipment.Misc
import Dodge.Creature.HandPos
import qualified Data.IntMap.Strict as IM
import Control.Lens
@@ -27,19 +28,19 @@ import Shape
import ShapePicture
basicCrPict :: IM.IntMap Item -> Creature -> SPic
basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape m cr)
basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)
crCamouflage :: Creature -> CamouflageStatus
crCamouflage _ = FullyVisible
basicCrShape :: IM.IntMap Item -> Creature -> Shape
basicCrShape m cr
basicCrShape :: Creature -> Shape
basicCrShape cr
| crCamouflage cr == Invisible = mempty
| otherwise =
scaleSH (V3 crsize crsize crsize) $
mconcat
[ colorSH (_skinHead cskin) $ scalp m cr
, colorSH (_skinUpper cskin) $ upperBody m cr
[ colorSH (_skinHead cskin) $ scalp cr
, colorSH (_skinUpper cskin) $ upperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
]
where
@@ -68,17 +69,17 @@ deadFeet :: Creature -> Shape
{-# INLINE deadFeet #-}
deadFeet = feet
arms :: IM.IntMap Item -> Creature -> Shape
arms :: Creature -> Shape
{-# INLINE arms #-}
arms m cr =
arms cr =
(^. _1) $
translateToRightHand m cr aHand
<> translateToLeftHand m cr aHand
translateToRightHand cr aHand
<> translateToLeftHand cr aHand
where
aHand = noPic $ translateSHz (-4) . upperPrismPolyHalfST 4 $ polyCirc 3 4
deadScalp :: IM.IntMap Item -> Creature -> Shape
deadScalp m cr = deadRot cr . translateSHz 10 . scalp m $ cr
deadScalp :: Creature -> Shape
deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
deadRot :: Creature -> Shape -> Shape
deadRot cr = overPosSH (Q.rotateToZ d)
@@ -89,26 +90,18 @@ deadRot cr = overPosSH (Q.rotateToZ d)
(addZ 0 . unitVectorAtAngle . subtract (_crDir cr + pi))
(damageDirection $ _crDamage cr)
scalp :: IM.IntMap Item -> Creature -> Shape
scalp :: Creature -> Shape
{-# INLINE scalp #-}
scalp m cr = overPosSH (\p -> fst (headPQ m cr `Q.comp` (p,Q.qID))) fhead
scalp cr = overPosSH (translateToES cr OnHead) fhead
-- | twists cr = translateSHxy 0 5 . rotateSH (-1) $ translateSHxy (negate 2.5) 0.25 fhead
-- | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead
-- | otherwise = translateSHxy 2.5 0 fhead
where
fhead = colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5
torso :: IM.IntMap Item -> Creature -> Shape
torso :: Creature -> Shape
{-# INLINE torso #-}
torso m cr = overPosSH (\p -> fst (backPQ m cr `Q.comp` (p,Q.qID))) tsh
-- | oneH cr = rotateSH 0.5 tsh
-- | twists cr =
-- translateSHxy 0 3 . rotateSH (-1.3) $ tsh
---- mconcat
---- [ rotateSH (negate 0.2) . translateSHxy 2 3 . rotateSH (negate 0.4) $ aShoulder
---- , rotateSH (negate 0.2) . translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
---- ]
-- | otherwise = tsh
torso cr = overPosSH (translateToES cr OnBack) tsh
where
tsh =
mconcat
@@ -117,20 +110,20 @@ torso m cr = overPosSH (\p -> fst (backPQ m cr `Q.comp` (p,Q.qID))) tsh
]
aShoulder = scaleSH (V3 10 10 1) baseShoulder
deadUpperBody :: IM.IntMap Item -> Creature -> Shape
deadUpperBody m cr = deadRot cr . translateSHz (negate 10) . upperBody m $ cr
deadUpperBody :: Creature -> Shape
deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
baseShoulder :: Shape
{-# INLINE baseShoulder #-}
baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
upperBody :: IM.IntMap Item -> Creature -> Shape
upperBody :: Creature -> Shape
{-# INLINE upperBody #-}
upperBody m cr = arms m cr <> shoulderSH (torso m cr)
upperBody cr = arms cr <> shoulderSH (torso cr)
shoulderSH :: Shape -> Shape
shoulderSH = translateSHz 20
drawEquipment :: IM.IntMap Item -> Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment m cr = foldMap (itemEquipPict m cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
src/Dodge/Creature/Statistics.hs
+12 -8
View File
@@ -6,11 +6,15 @@ module Dodge.Creature.Statistics (
crIntelligence,
) where
import Dodge.Data.Equipment.Misc
import qualified Data.Map.Strict as M
import NewInt
import Dodge.Data.LWorld
import Data.Maybe
import qualified IntMapHelp as IM
--import qualified IntMapHelp as IM
import qualified Data.IntMap.Strict as IM
import LensHelp
import qualified Data.IntSet as IS
crDexterity :: Creature -> Int
crDexterity cr = case cr ^. crType of
@@ -55,17 +59,17 @@ equipmentStrValue itm = case _itType itm of
EQUIP POWERLEGS -> 3
_ -> 0
crCurrentEquipment :: LWorld -> Creature -> NewIntMap InvInt Item
crCurrentEquipment lw = over unNIntMap (IM.filter (isJust . (^? itLocation . ilEquipSite . _Just))) . fmap f . _crInv
crCurrentEquipment :: LWorld -> Creature -> M.Map EquipSite Item
crCurrentEquipment lw = fmap f . _crEquipment
where
f i = lw ^?! items . ix i
f i = lw ^?! items . ix (_unNInt i)
strFromHeldItem :: LWorld -> Creature -> Int
strFromHeldItem lw cr = fromMaybe 0 $ do
Aiming <- cr ^? crStance . posture
i <- cr ^? crManipulation . manObject . imRootSelectedItem
j <- cr ^? crInv . ix i
fmap (negate . itemWeight) $ lw ^? items . ix j
Aiming {} <- cr ^? crStance . posture
is <- cr ^? crManipulation . manObject . imAttachedItems
let js = IM.elems $ IM.restrictKeys (cr ^. crInv . unNIntMap) is
return . negate . sum . fmap itemWeight $ IM.restrictKeys (lw ^. items) $ IS.fromList js
itemWeight :: Item -> Int
itemWeight it = case it ^. itType of
src/Dodge/Creature/Test.hs
+10 -24
View File
@@ -26,11 +26,9 @@ module Dodge.Creature.Test (
import NewInt
import qualified Data.IntMap.Strict as IM
import Dodge.Item.Grammar
import Dodge.Creature.Radius
import Dodge.Data.Equipment.Misc
import Dodge.Data.AimStance
import Dodge.Item.AimStance
import Control.Lens
import Data.List (find)
import Data.Maybe
@@ -89,35 +87,24 @@ crAwayFromPost cr = case find sentinelGoal . _apGoal $ _crActionPlan cr of
sentinelGoal (SentinelAt _ _) = True
sentinelGoal _ = False
--crCanShoot :: Creature -> Bool
--crCanShoot cr = crIsAiming cr && crWeaponReady cr
crInAimStance :: AimStance -> Creature -> Bool
crInAimStance as cr = cr ^? crStance . posture . aimStance == Just as
crInAimStance :: AimStance -> IM.IntMap Item -> Creature -> Bool
crInAimStance as m cr = crIsAiming cr && mitstance == Just as
where
mitstance = do
i <- cr ^? crManipulation . manObject . imRootSelectedItem
--itm <- invRootTrees' (cr ^. crInv) ^? ix i
itm <- fmap (fmap (\(a,b,_) -> (a,b))) $ invIMDT (fmap (\k -> m ^?! ix k) (cr ^. crInv)) ^? ix (_unNInt i)
return $ aimStance itm
--cr ^? crInv . ix i . itUse . heldAim . aimStance
oneH :: IM.IntMap Item -> Creature -> Bool
oneH :: Creature -> Bool
oneH = crInAimStance OneHand
twoFlat :: IM.IntMap Item -> Creature -> Bool
twoFlat :: Creature -> Bool
twoFlat = crInAimStance TwoHandFlat
twists :: IM.IntMap Item -> Creature -> Bool
twists m cr = crInAimStance TwoHandUnder m cr || crInAimStance TwoHandOver m cr
twists :: Creature -> Bool
twists cr = crInAimStance TwoHandUnder cr || crInAimStance TwoHandOver cr
-- the use of crOldPos is because the damage position is calculated on the
-- previous frame
-- Not sure if it is a good idea
crIsArmouredFrom :: IM.IntMap Item -> Point2 -> Creature -> Bool
crIsArmouredFrom m p cr = fromMaybe False $ do
invid <- cr ^? crEquipment . ix OnChest
itid <- cr ^? crInv . ix invid
NInt itid <- cr ^? crEquipment . ix OnChest
ittype <- m ^? ix itid . itType
return $
EQUIP FRONTARMOUR == ittype
@@ -125,11 +112,10 @@ crIsArmouredFrom m p cr = fromMaybe False $ do
&& angleVV (unitVectorAtAngle (_crDir cr + frontarmdirection)) (p -.- _crOldPos cr) < pi / 2
where
-- even though angleVV can generate NaN, the comparison seems to deal with it
frontarmdirection
| crInAimStance OneHand m cr = 0.5
| crInAimStance TwoHandUnder m cr = negate 1
| crInAimStance TwoHandOver m cr = negate 1
| crInAimStance OneHand cr = 0.5
| crInAimStance TwoHandUnder cr = negate 1
| crInAimStance TwoHandOver cr = negate 1
| otherwise = 0
--crOnSeg :: Point2 -> Point2 -> Creature -> Bool
src/Dodge/Creature/Update.hs
+1 -1
View File
@@ -107,7 +107,7 @@ corpseOrGib cr w = w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
_ -> addcorpse thecorpse
where
addcorpse ctype = plNew (cWorld . lWorld . corpses) cpID ctype
thecorpse = makeCorpse (w ^. cWorld . lWorld . items) cr
thecorpse = makeCorpse cr
scorchSPic :: SPic -> SPic
scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
src/Dodge/Creature/Volition.hs
+2 -1
View File
@@ -6,6 +6,7 @@ module Dodge.Creature.Volition (
shootFirstMiss,
) where
import Dodge.Data.AimStance
import Dodge.Data.Creature
import Dodge.Data.CreatureEffect
import Dodge.SoundLogic.LoadSound
@@ -13,7 +14,7 @@ import Geometry
holsterWeapon, drawWeapon :: Action
holsterWeapon = DoImpulses [ChangePosture AtEase, MakeSound whiteNoiseFadeOutS]
drawWeapon = DoImpulses [ChangePosture Aiming, MakeSound whiteNoiseFadeInS]
drawWeapon = DoImpulses [ChangePosture $ Aiming OneHand, MakeSound whiteNoiseFadeInS]
shootTillEmpty :: Action
--shootTillEmpty = (crCanShoot `DoActionWhile` DoImpulses [UseItem])
src/Dodge/Creature/YourControl.hs
+47 -35
View File
@@ -1,20 +1,18 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Creature.YourControl (
yourControl,
) where
module Dodge.Creature.YourControl (yourControl) where
import qualified Data.IntMap.Strict as IM
import Dodge.Creature.MoveType
import Dodge.Data.Equipment.Misc
import Control.Monad
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.AssignHotkey
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.Impulse.UseItem
import Dodge.Creature.MoveType
import Dodge.Data.AimStance
import Dodge.Data.Equipment.Misc
import Dodge.Data.World
import Dodge.AssignHotkey
import Dodge.InputFocus
import Dodge.Inventory
import Dodge.Item.AimStance
@@ -29,32 +27,30 @@ import qualified SDL
yourControl :: Creature -> World -> World
yourControl _ w
| inTextInputFocus w = w
| Just x <- w ^? hud . hudElement . subInventory
| Just x <- w ^? hud . subInventory
, f x =
w
& cWorld . lWorld . creatures . ix 0 %~ wasdWithAiming w
& tryClickUse pkeys
& handleHotkeys
| otherwise =
w & cWorld . lWorld . creatures . ix 0 %~ wasdWithAiming w
| otherwise = w & cWorld . lWorld . creatures . ix 0 %~ wasdWithAiming w
where
f NoSubInventory = True
f ExamineInventory = True
f _ = False
f = \case
NoSubInventory -> True
ExamineInventory -> True
_ -> False
pkeys = w ^. input . mouseButtons
-- the following only works because modifier keys are ordered after scancode "hotkeys"
handleHotkeys :: World -> World
handleHotkeys w
| ispressed SDL.ScancodeLShift || ispressed SDL.ScancodeRShift
, Just hk <-
listToMaybe . mapMaybe scancodeToHotkey . M.keys $ w ^. input . pressedKeys
, (hk:_) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
, Just invid <- lw ^? creatures . ix 0 . crManipulation . manObject . imSelectedItem
, Just itid <- lw ^? creatures . ix 0 . crInv . ix invid =
w & cWorld . lWorld %~ assignHotkey (NInt itid) hk
| ispressed SDL.ScancodeLCtrl || ispressed SDL.ScancodeRCtrl
, Just hk <-
listToMaybe . mapMaybe scancodeToHotkey . M.keys $
w ^. input . pressedKeys
, (hk:_) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
, Just itid <- lw ^? hotkeys . ix hk . unNInt
, Just invid <- lw ^? items . ix itid . itLocation . ilInvID =
w & invSetSelectionPos 0 (_unNInt invid)
@@ -64,17 +60,26 @@ handleHotkeys w
w
(M.intersectionWith (,) thehotkeys (w ^. input . pressedKeys))
where
pkeys = w ^. input . pressedKeys
ispressed k = k `M.member` _pressedKeys (_input w)
thehotkeys = M.mapKeys hotkeyToScancode $ w ^. cWorld . lWorld . hotkeys
lw = w ^. cWorld . lWorld
--modifierKeys :: S.Set SDL.Scancode
--modifierKeys = S.fromList
-- [ SDL.ScancodeLShift
-- , SDL.ScancodeRShift
-- , SDL.ScancodeRCtrl
-- , SDL.ScancodeLCtrl
-- ]
useHotkey :: World -> (NewInt ItmInt, Int) -> World
useHotkey w (NInt itid, pt) = fromMaybe w $ do
invid <- w ^? cWorld . lWorld . items . ix itid . itLocation . ilInvID . unNInt
useItem invid pt w
hotkeyToScancode :: Hotkey -> SDL.Scancode
hotkeyToScancode x = case x of
hotkeyToScancode = \case
HotkeyQ -> SDL.ScancodeQ
HotkeyE -> SDL.ScancodeE
HotkeyR -> SDL.ScancodeE
@@ -94,7 +99,7 @@ hotkeyToScancode x = case x of
Hotkey0 -> SDL.Scancode0
scancodeToHotkey :: SDL.Scancode -> Maybe Hotkey
scancodeToHotkey x = case x of
scancodeToHotkey = \case
SDL.ScancodeQ -> Just HotkeyQ
SDL.ScancodeE -> Just HotkeyE
SDL.ScancodeR -> Just HotkeyR
@@ -129,27 +134,33 @@ wasdAim inp w cr
| Just 0 <- inp ^? mouseButtons . ix SDL.ButtonRight
, Nothing <- inp ^? mouseButtons . ix SDL.ButtonLeft =
setAimPosture (w ^. cWorld . lWorld . items) cr
| SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn (w ^. cWorld . lWorld)
mousedir cr
| Aiming <- cr ^. crStance . posture = removeAimPosture m cr
| SDL.ButtonRight `M.member` _mouseButtons inp =
aimTurn (w ^. cWorld . lWorld) mousedir cr
| Aiming {} <- cr ^. crStance . posture = removeAimPosture cr
| otherwise = creatureTurnTowardDir (_crMvAim cr) 0.2 cr
where
m = w ^. cWorld . lWorld . items
mousedir = argV $ w ^. cWorld . lWorld . lAimPos - (cr ^. crPos)
setAimPosture :: IM.IntMap Item -> Creature -> Creature
setAimPosture m = (crStance . posture .~ Aiming) . doAimTwist m (- twoHandTwistAmount)
setAimPosture m cr = fromMaybe cr $ do
invid <- cr ^? crManipulation . manObject . imRootSelectedItem
itid <- cr ^? crInv . ix invid
as <- fmap itemBaseStance $ m ^? ix itid
return $ cr
& crStance . posture .~ Aiming as
& doAimTwist as (- twoHandTwistAmount)
doAimTwist :: IM.IntMap Item -> Float -> Creature -> Creature
doAimTwist m x cr = fromMaybe cr $ do
itRef <- cr ^? crManipulation . manObject . imRootSelectedItem
itid <- cr ^? crInv . ix itRef
astance <- fmap itemBaseStance $ m ^? ix itid
guard $ astance == TwoHandOver || astance == TwoHandUnder
return $ cr & crDir +~ x
doAimTwist :: AimStance -> Float -> Creature -> Creature
doAimTwist as x
| as == TwoHandOver || as == TwoHandUnder = crDir +~ x
| otherwise = id
removeAimPosture :: IM.IntMap Item -> Creature -> Creature
removeAimPosture m = (crStance . posture .~ AtEase) . doAimTwist m twoHandTwistAmount
removeAimPosture :: Creature -> Creature
removeAimPosture cr = fromMaybe cr $ do
as <- cr ^? crStance . posture . aimStance
return $ cr
& crStance . posture .~ AtEase
& doAimTwist as twoHandTwistAmount
twoHandTwistAmount :: Float
twoHandTwistAmount = 1.6 * pi
@@ -231,6 +242,7 @@ tryClickUse pkeys w = fromMaybe w $ do
^? cWorld . lWorld . creatures . ix 0
. crManipulation
. manObject
. imSelectedItem . unNInt of
. imSelectedItem
. unNInt of
Just invid -> useItem invid ltime w
Nothing -> interactWithCloseObj <$> getSelectedCloseObj w ?? w
src/Dodge/Data/AimStance.hs
+9
View File
@@ -1,6 +1,12 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.AimStance where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
data AimStance
= TwoHandUnder
@@ -8,3 +14,6 @@ data AimStance
| TwoHandFlat
| OneHand
deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''AimStance
deriveJSON defaultOptions ''AimStance
src/Dodge/Data/CardinalPoint.hs
+1 -1
View File
@@ -26,7 +26,7 @@ data CardinalCover
| NSW
| NS
data XInfinity a = NegInf | NonInf a | PosInf
data XInfinity a = NegInf | NonInf {_nonInf :: a} | PosInf
deriving (Eq, Ord, Show)
makeLenses ''XInfinity
src/Dodge/Data/Config.hs
+9 -9
View File
@@ -35,7 +35,7 @@ data NumShadowCasters
| NumShadowCasters20
deriving (Show,Eq,Bounded,Ord,Enum)
data Configuration = Configuration
data Config = Config
{ _volume_master :: Float
, _volume_sound :: Float
, _volume_music :: Float
@@ -58,9 +58,9 @@ data Configuration = Configuration
}
deriving (Show)
windowXFloat :: Configuration -> Float
windowXFloat :: Config -> Float
windowXFloat = fromIntegral . _windowX
windowYFloat :: Configuration -> Float
windowYFloat :: Config -> Float
windowYFloat = fromIntegral . _windowY
data DebugBool
@@ -88,8 +88,8 @@ data DebugBool
| Show_walls_near_point_you
| Show_walls_near_segment
| Show_zone_near_point_cursor
| Show_zone_circ
| Inspect_wall
| Show_nodes_near_select
| Show_path_between
| Select_creature
deriving (Eq, Ord, Bounded, Enum, Show)
@@ -124,9 +124,9 @@ applyResFactor rf = case rf of
-- EighthRes -> 8
-- SixteenthRes -> 16
defaultConfig :: Configuration
defaultConfig :: Config
defaultConfig =
Configuration
Config
{ _volume_master = 1
, _volume_sound = 1
, _volume_music = 0
@@ -148,13 +148,13 @@ defaultConfig =
, _debug_view_clip_bounds = NoRoomClipBoundaries
}
debugOn :: DebugBool -> Configuration -> Bool
debugOn :: DebugBool -> Config -> Bool
debugOn db = S.member db . _debug_booleans
makeLenses ''Configuration
makeLenses ''Config
deriveJSON defaultOptions ''NumShadowCasters
deriveJSON defaultOptions ''ResFactor
deriveJSON defaultOptions ''ShadowRendering
deriveJSON defaultOptions ''RoomClipping
deriveJSON defaultOptions ''DebugBool
deriveJSON defaultOptions ''Configuration
deriveJSON defaultOptions ''Config
src/Dodge/Data/Creature.hs
+1 -1
View File
@@ -48,7 +48,7 @@ data Creature = Creature
, _crHP :: Int
, _crInv :: NewIntMap InvInt Int
, _crManipulation :: Manipulation
, _crEquipment :: M.Map EquipSite (NewInt InvInt)
, _crEquipment :: M.Map EquipSite (NewInt ItmInt)
, _crDamage :: [Damage]
, _crPain :: Int
, _crStance :: Stance
src/Dodge/Data/Creature/Stance.hs
+6 -2
View File
@@ -3,8 +3,12 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Creature.Stance where
module Dodge.Data.Creature.Stance
( module Dodge.Data.Creature.Stance
, module Dodge.Data.AimStance
)where
import Dodge.Data.AimStance
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -32,7 +36,7 @@ data FootForward = LeftForward | RightForward
deriving (Eq, Ord, Show, Read) --Generic, Flat)
data Posture
= Aiming
= Aiming {_aimStance :: AimStance}
| AtEase
deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/EquipType.hs
+3 -3
View File
@@ -22,9 +22,9 @@ eitType = \case
BRAINHAT -> GoesOnHead
HAT -> GoesOnHead
HEADLAMP -> GoesOnHead
POWERLEGS -> GoesOnLegs
SPEEDLEGS -> GoesOnLegs
JUMPLEGS -> GoesOnLegs
POWERLEGS -> GoesOnLeg
SPEEDLEGS -> GoesOnLeg
JUMPLEGS -> GoesOnLeg
FUELPACK -> GoesOnBack
BULLETBELTPACK -> GoesOnBack
BULLETBELTBRACER -> GoesOnWrist
src/Dodge/Data/Equipment/Misc.hs
+3 -2
View File
@@ -13,7 +13,7 @@ data EquipType
| GoesOnChest
| GoesOnBack
| GoesOnWrist
| GoesOnLegs
| GoesOnLeg
deriving (Eq, Ord, Show, Read)
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
@@ -24,7 +24,8 @@ data EquipSite
| OnBack
| OnLeftWrist
| OnRightWrist
| OnLegs
| OnLeftLeg
| OnRightLeg
-- | OnSpecial
deriving (Eq, Ord, Show, Read)
src/Dodge/Data/HUD.hs
+15 -20
View File
@@ -5,42 +5,35 @@
module Dodge.Data.HUD where
import qualified Data.IntSet as IS
import Dodge.Data.Item.Location
import NewInt
import Control.Lens
import Data.IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Dodge.Data.Combine
import Dodge.Data.Item.Location
import Dodge.Data.SelectionList
import Geometry.Data
data HUDElement
= DisplayInventory
{ _subInventory :: SubInventory
, _diSections :: IMSS ()
, _diSelection :: Maybe (Int, Int, IntSet)
, _diInvFilter :: Maybe String
, _diCloseFilter :: Maybe String
}
import NewInt
data SubInventory
= NoSubInventory
| ExamineInventory
| MapperInventory
{_mapInvOffset :: Point2
| MapperInventory
{ _mapInvOffset :: Point2
, _mapInvZoom :: Float
, _mapInvItmID :: NewInt ItmInt
}
| CombineInventory
{ _ciSections :: IntMap (SelectionSection CombinableItem)
, _ciSelection :: Maybe (Int, Int, IS.IntSet)
{ _ciSections :: IMSS CombinableItem
, _ciSelection :: Maybe Selection
, _ciFilter :: Maybe String
}
| DisplayTerminal {_termID :: Int}
data HUD = HUD
{ _hudElement :: HUDElement
{ _subInventory :: SubInventory
, _diSections :: IMSS ()
, _diSelection :: Maybe Selection
, _diInvFilter :: Maybe String
, _diCloseFilter :: Maybe String
, _carteCenter :: Point2
, _carteZoom :: Float
, _carteRot :: Float
@@ -48,6 +41,8 @@ data HUD = HUD
, _closeButtons :: [Int]
}
data Selection = Sel {_slSec :: Int, _slInt :: Int, _slSet :: IS.IntSet}
makeLenses ''HUD
makeLenses ''HUDElement
makeLenses ''Selection
makeLenses ''SubInventory
src/Dodge/Data/Input.hs
+1 -6
View File
@@ -17,12 +17,7 @@ data MouseContext
| MouseInGame
| MouseMenuClick {_mcoMenuClick :: Int}
| MouseMenuCursor
| OverInvDrag {_mcoDragSection :: Int
, _mcoMaybeSelect :: Maybe (Int,Int)
, _mcoAboveSelect :: Maybe (Int,Int)
, _mcoBelowSelect :: Maybe (Int,Int)
}
-- | OverInvDragSelect { _mcoSecSelStart :: (Int,Int), _mcoSelEnd :: Maybe Int }
| OverInvDrag {_mcoDragSection :: Int , _mcoMaybeSelect :: Maybe (Int,Int) }
| OverInvDragSelect { _mcoSecSelStart :: Maybe (Int,Int), _mcoSelEnd :: Maybe Int }
| OverInvSelect { _mcoInvSelect :: (Int,Int)}
| OverCombFiltInv { _mcoInvFilt :: (Int,Int)}
src/Dodge/Data/RightButtonOptions.hs
+12 -18
View File
@@ -1,27 +1,24 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.RightButtonOptions where
import Dodge.Data.Item.Location
import NewInt
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.Equipment.Misc
import Dodge.Data.Item.Location
import NewInt
data RightButtonOptions
= NoRightButtonOptions
| EquipOptions { _opSel :: Int }
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data RightButtonState
= NoRightButtonState
| EquipOptions {_opSel :: Int}
data EquipmentAllocation
= DoNotMoveEquipment
| PutOnEquipment
{ _allocNewPos :: EquipSite
}
| PutOnEquipment {_allocNewPos :: EquipSite}
| MoveEquipment
{ _allocNewPos :: EquipSite
, _allocOldPos :: EquipSite
@@ -29,18 +26,15 @@ data EquipmentAllocation
| SwapEquipment
{ _allocNewPos :: EquipSite
, _allocOldPos :: EquipSite
, _allocSwapID :: NewInt InvInt
, _allocSwapID :: NewInt ItmInt
}
| ReplaceEquipment
{ _allocNewPos :: EquipSite
, _allocRemoveID :: NewInt InvInt
, _allocRemoveID :: NewInt ItmInt
}
| RemoveEquipment
{ _allocOldPos :: EquipSite
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
| RemoveEquipment {_allocOldPos :: EquipSite}
makeLenses ''RightButtonOptions
makeLenses ''RightButtonState
makeLenses ''EquipmentAllocation
deriveJSON defaultOptions ''EquipmentAllocation
deriveJSON defaultOptions ''RightButtonOptions
deriveJSON defaultOptions ''RightButtonState
src/Dodge/Data/SelectionList.hs
+1 -3
View File
@@ -36,9 +36,7 @@ data SelectionSection a = SelectionSection
type IMSS a = IntMap (SelectionSection a)
data SelectionWidth
= FixedSelectionWidth Int
| UseItemWidth
data SelectionWidth = FixedSelectionWidth Int | UseItemWidth
data SelectionItem a
= SelItem
src/Dodge/Data/Terminal.hs
-2
View File
@@ -50,7 +50,6 @@ data TCom
= TCInfo String String -- this may not be necessary, to revisit
| TCBase
| TCDamageCommand
| TCSensorInfo
data TmWdWd
= TmWdId
@@ -61,7 +60,6 @@ data TmWdWd
| TmWdWdDoDeathTriggers
| TmTmClearDisplayedLines
| TmTmSetStatus TerminalStatus
-- | TmGetSensor String
makeLenses ''Terminal
makeLenses ''TerminalLine
src/Dodge/Data/Terminal/Status.hs
+1
View File
@@ -13,6 +13,7 @@ data TerminalStatus
| TerminalLineRead
| TerminalTextInput {_tiText :: String}
| TerminalPressTo {_tptString :: String}
| TerminalWaiting
deriving (Eq,Show)
makeLenses ''TerminalStatus
src/Dodge/Data/Universe.hs
+3 -3
View File
@@ -34,7 +34,7 @@ data Universe = Universe
, _uvScreenLayers :: [ScreenLayer]
, _uvIOEffects :: Universe -> IO Universe
, _uvSideEffects :: Seq SideEffect
, _uvConfig :: Configuration
, _uvConfig :: Config
, _uvTestString :: Universe -> [String]
, _uvCanContinue :: Bool
, _uvMSeed :: Maybe Int
@@ -49,8 +49,8 @@ data Universe = Universe
}
data DebugItem = DebugItem
{ _debugPic :: Universe -> Picture
, _debugMessage :: Universe -> [String]
{ _debugPic :: Picture
, _debugMessage :: [String]
, _debugInfo :: DebugInfo
}
src/Dodge/Data/World.hs
+1 -1
View File
@@ -41,7 +41,7 @@ data World = World
, _playingSounds :: M.Map SoundOrigin Sound
, _input :: Input
, _testFloat :: Float
, _rbOptions :: RightButtonOptions
, _rbState :: RightButtonState
, _hud :: HUD
, _worldEventFlags :: Set WorldEventFlag
, _crZoning :: IntMap (IntMap IntSet)
src/Dodge/Debug.hs
+39 -37
View File
@@ -1,5 +1,5 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Debug where
module Dodge.Debug (debugEvents) where
import Data.Aeson.Types
import AesonHelp
@@ -15,59 +15,61 @@ import Dodge.WorldEvent.ThingsHit
import Geometry.Vector
import qualified SDL
import Data.Ord
import Data.Foldable (fold)
debugEvents :: Universe -> Universe
debugEvents u = case dbools ^. at Enable_debug of
Nothing -> u
Just () -> S.foldr debugEvent u dbools
Just () -> S.foldr debugEvent (u & uvDebug .~ mempty) dbools
where
dbools = u ^. uvConfig . debug_booleans
debugEvent :: DebugBool -> Universe -> Universe
debugEvent db u = u & uvDebug . at db .~ debugEvent' u db
-- case db of
-- Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
-- Circ_collision_test -> u & uvDebug . at Circ_collision_test ?~ circCollisionDebugItem u
-- Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
-- _ -> u
debugEvent db u = u & uvDebug . at db .~ debugItem db u
debugEvent' :: Universe -> DebugBool -> Maybe DebugItem
debugEvent' u = \case
Collision_test -> Just $ collisionDebugItem u
Circ_collision_test -> Just $ circCollisionDebugItem u
Select_creature -> Just $ selectCreatureDebugItem u
Show_walls_near_point_cursor -> Just
(DebugItem (const $ drawWallsNearCursor w) (const mempty) NoDebugInfo)
Show_walls_near_segment -> Just
(DebugItem (const $ drawWallsNearSegment w) (const mempty) NoDebugInfo)
_ -> Nothing
where
w = u ^. uvWorld
debugItem :: DebugBool -> Universe -> Maybe DebugItem
debugItem = \case
Collision_test -> constDPic (drawCollisionTest . _uvWorld)
Circ_collision_test -> constDPic (drawCircCollisionTest . _uvWorld)
Select_creature -> Just . selectCreatureDebugItem
Show_walls_near_point_cursor -> constDPic (drawWallsNearCursor . _uvWorld)
Show_walls_near_segment -> constDPic (drawWallsNearSegment . _uvWorld)
Enable_debug -> const Nothing
Noclip -> const Nothing
Remove_LOS -> const Nothing
Cull_more_lights -> const Nothing
Close_shape_culling -> const Nothing
Bound_box_screen -> const Nothing
Show_ms_frame -> const Nothing
View_boundaries -> constDPic (viewBoundaries . _uvWorld)
Show_bound_box -> constDPic (drawBoundingBox . _uvWorld)
Show_wall_search_rays -> constDPic $ drawWallSearchRays . _uvWorld
Show_dda_test -> constDPic $ drawDDATest . _uvWorld
Show_far_wall_detect -> constDPic $ drawFarWallDetect . _uvWorld
Show_walls_near_point_you -> constDPic $ drawWallsNearYou . _uvWorld
Show_zone_near_point_cursor -> constDPic $ drawZoneNearPointCursor . _uvWorld
Show_zone_circ -> constDPic $ drawZoneCirc . _uvWorld
Inspect_wall -> constDPic $ drawInspectWalls . _uvWorld
Cr_awareness -> constDPic $ drawCreatureDisplayTexts . _uvWorld
Show_sound -> constDPic $ \u ->
fold (M.map (soundPic (u ^. uvConfig) (u ^. uvWorld)) $ u ^. uvWorld . playingSounds)
Cr_status -> constDPic $ \u -> drawCrInfo (u ^. uvConfig) (u ^. uvWorld)
Mouse_position -> constDPic $ drawMousePosition . _uvWorld
Walls_info -> constDPic $ drawWlIDs . _uvWorld
Pathing -> constDPic $ \u -> drawPathing (u ^. uvConfig) (u ^. uvWorld)
Show_path_between -> constDPic $ drawPathBetween . _uvWorld
collisionDebugItem :: Universe -> DebugItem
collisionDebugItem u =
DebugItem
{ _debugPic = const $ drawCollisionTest $ u ^. uvWorld
, _debugMessage = const []
, _debugInfo = NoDebugInfo
}
constDPic :: (Universe -> Picture) -> Universe -> Maybe DebugItem
constDPic p u = Just $ DebugItem (p u) mempty NoDebugInfo
selectCreatureDebugItem :: Universe -> DebugItem
selectCreatureDebugItem u =
DebugItem
{ _debugPic = const mempty
, _debugMessage = debugSelectCreatureMessage
{ _debugPic = mempty
, _debugMessage = debugSelectCreatureMessage u
, _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
}
circCollisionDebugItem :: Universe -> DebugItem
circCollisionDebugItem _ =
DebugItem
{ _debugPic = drawCircCollisionTest . (^. uvWorld)
, _debugMessage = const []
, _debugInfo = NoDebugInfo
}
scrollDebugInfoInt :: Int -> Universe -> DebugInfo -> DebugInfo
scrollDebugInfoInt i u
| SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
src/Dodge/Debug/Picture.hs
+64 -53
View File
@@ -4,7 +4,6 @@ module Dodge.Debug.Picture where
import Control.Lens
import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
import Dodge.Base
@@ -41,7 +40,7 @@ printRotPoint r p =
. uncurryV translate p
$ fold [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: Configuration -> Camera -> [Point2]
outsideScreenPolygon :: Config -> Camera -> [Point2]
outsideScreenPolygon cfig w = [tr, tl, bl, br]
where
scRot = rotateV (w ^. camRot)
@@ -57,7 +56,7 @@ outsideScreenPolygon cfig w = [tr, tl, bl, br]
-- cannot only test if walls are on screen, but also if they are on the cone
-- towards the center of sight
lineOnScreenCone :: Configuration -> World -> Point2 -> Point2 -> Bool
lineOnScreenCone :: Config -> World -> Point2 -> Point2 -> Bool
lineOnScreenCone cfig w p1 p2 =
pointInPolygon p1 sp
|| pointInPolygon p2 sp
@@ -70,7 +69,7 @@ lineOnScreenCone cfig w p1 p2 =
| otherwise = orderPolygon ((w ^. wCam . camViewFrom) : sp')
sps = zip sp (tail sp ++ [head sp])
drawWallFace :: Configuration -> World -> Wall -> Picture
drawWallFace :: Config -> World -> Wall -> Picture
drawWallFace cfig w wall
| isRHS sightFrom x y || not (wlIsOpaque wall) = blank
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
@@ -79,7 +78,7 @@ drawWallFace cfig w wall
points = extendConeToScreenEdge cfig w sightFrom (x, y)
sightFrom = w ^. wCam . camViewFrom
extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2, Point2) -> [Point2]
extendConeToScreenEdge :: Config -> World -> Point2 -> (Point2, Point2) -> [Point2]
extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs
where
borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y]
@@ -93,7 +92,7 @@ extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [
-- the following assumes that the point a is inside the screen
-- it still works otherwise, but it might intersect two points:
-- it is not obvious which will be returned
intersectLinefromScreen :: Configuration -> World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen :: Config -> World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen cfig w a b =
listToMaybe
. mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
@@ -106,11 +105,13 @@ drawCollisionTest w = concat $ do
b <- w ^. input . heldWorldPos . at ButtonRight
return $
setLayer DebugLayer (color orange $ line [a, b])
<> foldMap (drawCrossCol red
-- . xyV3
. fst)
-- (collide3 (v2z a 0) (v2z b 0) w)
-- (collide3Floors (v2z a 10) (v2z b (-10)) $ w ^. cWorld . chasms)
<> foldMap
( drawCrossCol red
-- . xyV3
. fst
)
-- (collide3 (v2z a 0) (v2z b 0) w)
-- (collide3Floors (v2z a 10) (v2z b (-10)) $ w ^. cWorld . chasms)
(thingHit a b w)
drawCircCollisionTest :: World -> Picture
@@ -151,48 +152,47 @@ drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p :
zipWith (+.+) (square 1) $
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
debugDraw :: Configuration -> World -> Picture
{-# INLINE debugDraw #-}
debugDraw cfig w
showEnabledDebugs :: Config -> Picture
{-# INLINE showEnabledDebugs #-}
showEnabledDebugs cfig
| Enable_debug `S.member` _debug_booleans cfig =
pic
<> setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
| otherwise = mempty
where
pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
-- pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
ts = map show (S.toList $ _debug_booleans cfig)
debugDraw' :: Configuration -> World -> DebugBool -> Picture
{-# INLINE debugDraw' #-}
debugDraw' cfig w bl = case bl of
Enable_debug -> mempty
Noclip -> mempty
Remove_LOS -> mempty
Cull_more_lights -> mempty
Close_shape_culling -> mempty
Bound_box_screen -> mempty
Show_ms_frame -> mempty
View_boundaries -> viewBoundaries w
Show_bound_box -> drawBoundingBox w
Show_wall_search_rays -> drawWallSearchRays w
Show_dda_test -> drawDDATest w
Show_far_wall_detect -> drawFarWallDetect w
Show_walls_near_point_cursor -> mempty
Show_walls_near_segment -> mempty
Show_walls_near_point_you -> drawWallsNearYou w
Show_zone_near_point_cursor -> drawZoneNearPointCursor w
Inspect_wall -> drawInspectWalls w
Cr_awareness -> drawCreatureDisplayTexts w
Show_sound -> fold $ M.map (soundPic cfig w) $ _playingSounds w
Cr_status -> drawCrInfo cfig w
Mouse_position -> drawMousePosition w
Walls_info -> drawWlIDs w
Pathing -> drawPathing cfig w
Show_nodes_near_select -> undefined --drawNodesNearSelect w
Show_path_between -> drawPathBetween w
Collision_test -> mempty
Circ_collision_test -> mempty
Select_creature -> mempty
--debugDraw' :: Config -> World -> DebugBool -> Picture
--{-# INLINE debugDraw' #-}
--debugDraw' cfig w bl = case bl of
-- Enable_debug -> mempty
-- Noclip -> mempty
-- Remove_LOS -> mempty
-- Cull_more_lights -> mempty
-- Close_shape_culling -> mempty
-- Bound_box_screen -> mempty
-- Show_ms_frame -> mempty
-- View_boundaries -> mempty
-- Show_bound_box -> mempty
-- Show_wall_search_rays -> mempty
-- Show_dda_test -> mempty
-- Show_far_wall_detect -> mempty
-- Show_walls_near_point_cursor -> mempty
-- Show_walls_near_segment -> mempty
-- Show_walls_near_point_you -> drawWallsNearYou w
-- Show_zone_near_point_cursor -> drawZoneNearPointCursor w
-- Show_zone_circ -> drawZoneCirc w
-- Inspect_wall -> drawInspectWalls w
-- Cr_awareness -> drawCreatureDisplayTexts w
-- Show_sound -> fold $ M.map (soundPic cfig w) $ _playingSounds w
-- Cr_status -> drawCrInfo cfig w
-- Mouse_position -> drawMousePosition w
-- Walls_info -> drawWlIDs w
-- Pathing -> drawPathing cfig w
-- Show_path_between -> drawPathBetween w
-- Collision_test -> mempty
-- Circ_collision_test -> mempty
-- Select_creature -> mempty
drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
@@ -288,6 +288,17 @@ drawZoneNearPointCursor w =
mwp = mouseWorldPos (w ^. input) (w ^. wCam)
ps = [zoneOfPoint 50 mwp]
drawZoneCirc :: World -> Picture
drawZoneCirc w = concat $ do
a <- w ^. input . clickWorldPos . at ButtonLeft
b <- w ^. input . heldWorldPos . at ButtonLeft
let r = dist a b
ps = zoneOfCirc 50 a r
return $
setLayer DebugLayer (uncurryV translate a $ color red $ circle r)
<> setLayer DebugLayer (color green $ line [a, b])
<> foldMap (drawZoneCol orange 50) ps
drawDDATest :: World -> Picture
drawDDATest w =
foldMap (drawZoneCol orange 50) ps
@@ -315,7 +326,7 @@ viewBoundaries w =
p = w ^. wCam . camViewFrom
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
viewClipBounds :: Configuration -> World -> Picture
viewClipBounds :: Config -> World -> Picture
viewClipBounds cfig w
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_cwgRoomClipping $ _cwGen (_cWorld w))
@@ -338,7 +349,7 @@ drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
where
(x : xs) = w ^. wCam . camBoundBox
soundPic :: Configuration -> World -> Sound -> Picture
soundPic :: Config -> World -> Sound -> Picture
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
where
p = _soundPos s
@@ -382,14 +393,14 @@ drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls
where
p = worldPosToScreen (w ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl)
drawCrInfo :: Configuration -> World -> Picture
drawCrInfo :: Config -> World -> Picture
drawCrInfo cfig w =
setLayer FixedCoordLayer $
renderInfoListsAt (2 * hw - 400) 0 cfig cam $
mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
where
cam = w ^. wCam
-- drawPathing :: Configuration -> World -> Picture
-- drawPathing :: Config -> World -> Picture
-- drawPathing cfig w =
-- setLayer DebugLayer $
-- foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
@@ -424,7 +435,7 @@ drawCrInfo cfig w =
fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
hw = halfWidth cfig
drawPathing :: Configuration -> World -> Picture
drawPathing :: Config -> World -> Picture
drawPathing cfig w =
setLayer DebugLayer $
foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
src/Dodge/Debug/Terminal.hs
+15 -13
View File
@@ -1,7 +1,9 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Dodge.Debug.Terminal where
import Dodge.Inventory
import Data.Foldable
--import Dodge.Item.Location.Initialize
import Control.Applicative
@@ -13,14 +15,12 @@ import Dodge.Creature
import Dodge.Data.Universe
import Dodge.Inventory.Add
import Dodge.Item
--import Dodge.Menu.PushPop
--import qualified IntMapHelp as IM
import LensHelp
import MaybeHelp
import Text.Read (readMaybe)
applyTerminalString :: [String] -> Universe -> Universe
applyTerminalString ss = case ss of
applyTerminalString = \case
[] -> id
[s] -> applyTerminalCommand s
(s : ss') -> applyTerminalCommandArguments s ss'
@@ -28,16 +28,18 @@ applyTerminalString ss = case ss of
applyTerminalCommand :: String -> Universe -> Universe
applyTerminalCommand s = case s of
"NOCLIP" -> uvConfig . debug_booleans . at Noclip %~ toggleJust
['L', x] -> uvWorld %~ \w -> foldl' (flip createItemYou) w (inventoryX x)
-- (uvWorld . cWorld . lWorld %~ initSpecificCrItemLocations 0)
-- . (uvWorld . cWorld . lWorld . creatures . ix 0 . crInv .~ IM.fromList (zip [0 ..] $ inventoryX x))
-- . (uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ 50)
-- ['I','S',x,y] -> uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ read [x,y]
"GODON" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crType . avatarMaterial .~ Crystal
"GODOFF" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crType . avatarMaterial .~ Flesh
x -> fromMaybe id $ do
"GODON" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crType . avatarMaterial
.~ Crystal
"GODOFF" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crType . avatarMaterial
.~ Flesh
"CLEAR" -> \uv -> uv & uvWorld %~ destroyAllInvItems
(uv ^?! uvWorld . cWorld . lWorld . creatures . ix 0)
x -> fromMaybe (g x) $ do
(ibt, n) <- parseItem [x]
return $ uvWorld %~ flip (foldl' (&)) (replicate n ( createItemYou (itemFromBase ibt)))
return $ uvWorld
%~ flip (foldl' (&)) (replicate n ( createItemYou (itemFromBase ibt)))
where
g xs = uvWorld %~ \w -> foldl' (flip createItemYou) w (inventoryX xs)
applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe
applyTerminalCommandArguments command args u = case command of
@@ -68,7 +70,7 @@ parseItem (x : xs) =
<|> (readMaybe ("HELD {_ibtHeld=(" ++ x ++ " {_xNum=" ++ show (parseNum xs) ++ "})}") <&> (,1))
<|> (readMaybe ("ATTACH (" ++ x ++ ")") <&> (,parseNum xs))
<|> (readMaybe ("CONSUMABLE {_ibtConsumable=" ++ x ++ "}") <&> (,parseNum xs))
<|> (readMaybe ("AMMO {_ibtAmmo=" ++ x ++ "}") <&> (,parseNum xs))
<|> (readMaybe ("AMMOMAG {_ibtAmmoMag=" ++ x ++ "}") <&> (,parseNum xs))
<|> parseItem (xs & ix 0 .++~ (x ++ " "))
parseItem [] = Nothing
src/Dodge/Default/World.hs
+6 -12
View File
@@ -40,7 +40,7 @@ defaultWorld =
, _playingSounds = M.empty
, _randGen = mkStdGen 2
, _testFloat = 0
, _rbOptions = NoRightButtonOptions
, _rbState = NoRightButtonState
, _hud = defaultHUD
, _worldEventFlags = mempty
, _crZoning = mempty
@@ -159,20 +159,14 @@ defaultLWorld =
defaultHUD :: HUD
defaultHUD =
HUD
{ _hudElement = defaultDisplayInventory
{ _subInventory = NoSubInventory
, _diSections = mempty
, _diSelection = Just (Sel 1 0 mempty)
, _diInvFilter = mempty
, _diCloseFilter = mempty
, _carteCenter = V2 0 0
, _carteZoom = 0.5
, _carteRot = 0
, _closeItems = mempty
, _closeButtons = mempty
}
defaultDisplayInventory :: HUDElement
defaultDisplayInventory =
DisplayInventory
{ _subInventory = NoSubInventory
, _diSections = mempty
, _diSelection = Just (1, 0, mempty)
, _diInvFilter = mempty
, _diCloseFilter = mempty
}
src/Dodge/Default/World.hs.orig
-140
View File
@@ -1,140 +0,0 @@
module Dodge.Default.World where
import Dodge.Data.World
import Dodge.Zone.Size
import Dodge.Zone.Object
import Dodge.Base
import Geometry.Vector3D
import Geometry.Zone
--import Dodge.Config.KeyConfig
--import Dodge.Menu
--import Picture
import Geometry.Data
import Geometry.Polygon
--import Picture.Texture
--import Data.Preload
import Control.Lens
import System.Random
import qualified IntMapHelp as IM
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Graph.Inductive.Graph hiding ((&))
--import Data.Graph.Inductive.NodeMap
--import qualified Data.Vector.Fusion.Stream.Monadic as VS
defaultWorld :: World
defaultWorld = World
{ _keys = S.empty
, _magnets = IM.empty
, _mouseButtons = mempty
, _cameraCenter = V2 0 0
, _cameraRot = 0
, _cameraZoom = 1
, _itemZoom = 1
, _defaultZoom = 1
, _cameraViewFrom = V2 0 0
, _viewDistance = 1000
, _modifications = IM.empty
, _creatures = IM.empty
, _crZoning = Zoning IM.empty crZoneSize zoneOfCreature
, _creatureGroups = IM.empty
, _clouds = mempty
, _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
, _gusts = IM.empty
, _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos)
, _itemPositions = IM.empty
, _props = IM.empty
, _instantParticles = []
, _particles = []
, _newBeams = WorldBeams [] [] [] []
, _beams = WorldBeams [] [] [] []
, _walls = IM.empty
, _wallDamages = IM.empty
, _blocks = IM.empty
, _machines = IM.empty
, _terminals = IM.empty
, _doors = IM.empty
, _coordinates = IM.empty
, _triggers = IM.empty
, _wlZoning = Zoning IM.empty wlZoneSize zoneOfWall
, _floorItems = IM.empty
, _floorTiles = []
, _randGen = mkStdGen 2
, _mousePos = V2 0 0
, _testString = const . const []
, _debugPicture = mempty
, _yourID = 0
, _worldEvents = id
, _delayedEvents = []
, _pressPlates = IM.empty
, _buttons = IM.empty
, _toPlaySounds = M.empty
, _playingSounds = M.empty
, _corpses = IM.empty
, _decorations = IM.empty
--, _savedWorlds = M.empty
-- , _menuLayers = []
, _clickMousePos = V2 0 0
, _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
, _pathGraphP = mempty
<<<<<<< HEAD
, _pnZoning = Zoning mempty pnZoneSize (zonePos snd)
, _peZoning = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
=======
, _pnZoning = Zoning mempty wlZoneSize (zonePos snd)
, _peZoning = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
>>>>>>> efficientRuntime
, _hud = HUD
{ _hudElement = DisplayInventory NoSubInventory
, _carteCenter = V2 0 0
, _carteZoom = 0.5
, _carteRot = 0
}
, _lightSources = IM.empty
, _tempLightSources = [youLight]
, _closeObjects = []
, _rbOptions = NoRightButtonOptions
, _seenLocations = IM.fromList
[(0, (_crPos . you, "CURRENT POSITION"))
,(1, (const (V2 0 0) , "START POSITION"))
]
, _selLocation = 0
--, _keyConfig = defaultKeyConfigSDL
-- , _config = defaultConfig
, _sideEffects = return
, _shapes = mempty
, _distortions = []
, _gameRooms = []
, _roomClipping = []
, _unpauseClock = 0
, _worldBounds = defaultBounds
, _maybeWorld = Nothing'
, _rewindWorlds = []
, _timeFlow = NormalTimeFlow
, _hammers = defaultWorldHammers
, _backspaceTimer = 0
, _genParams = GenParams M.empty
, _genPlacements = IM.empty
, _genRooms = IM.empty
, _deathDelay = Nothing
, _testFloat = 0
, _boundBox = square 100
, _boundDist = (100,-100,100,-100)
, _lLine = (0,0)
, _rLine = (0,0)
, _lSelect = 0
, _rSelect = 0
}
defaultWorldHammers :: M.Map WorldHammer HammerPosition
defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound]
youLight :: TempLightSource
youLight = TLS
{ _tlsParam = LSParam
{_lsPos = V3 0 0 0
,_lsRad = 150
,_lsCol = 0.1
}
,_tlsUpdate = \w _ -> Just (youLight & tlsParam . lsPos .~ f (_crPos $ you w))
,_tlsTime = 0
}
where
f (V2 x y) = V3 x y 100
src/Dodge/DisplayInventory.hs
+30 -30
View File
@@ -9,6 +9,7 @@ module Dodge.DisplayInventory (
toggleCombineInv,
) where
import Dodge.Data.HUD
import Dodge.Inventory.CheckSlots
import NewInt
import Control.Applicative
@@ -16,7 +17,6 @@ import Control.Lens
import Control.Monad
import Data.IntMap.Merge.Strict
import qualified Data.IntMap.Strict as IM
import Data.IntSet (IntSet)
import Data.Maybe
import Data.Monoid
import Dodge.Base.You
@@ -39,30 +39,30 @@ import Picture.Base
updateCombinePositioning :: Universe -> Universe
updateCombinePositioning u =
u
& uvWorld . hud . hudElement . subInventory . ciSections
& uvWorld . hud . subInventory . ciSections
%~ updateCombineSections (_uvWorld u) (_uvConfig u)
& uvWorld . hud . hudElement . subInventory %~ checkCombineSelectionExists
& uvWorld . hud . subInventory %~ checkCombineSelectionExists
updateCombineSections ::
World ->
Configuration ->
Config ->
IM.IntMap (SelectionSection CombinableItem) ->
IM.IntMap (SelectionSection CombinableItem)
updateCombineSections w cfig =
updateSectionsPositioning
(const 0)
(w ^? hud . hudElement . subInventory . ciSelection . _Just)
(getAvailableListLines secondColumnParams cfig)
(w ^? hud . subInventory . ciSelection . _Just)
(getAvailableListLines secondColumnLDP cfig)
(IM.fromDistinctAscList [(-1, sfclose),(0, sclose')])
where
filtcurs = w ^? hud . hudElement . subInventory . ciSelection . _Just . _1 == Just (-1)
filtcurs = w ^? hud . subInventory . ciSelection . _Just . slSec == Just (-1)
(sfclose, sclose) =
filterSectionsPair
filtcurs
(flip . andOrRegex $ regexCombs invitms)
(IM.fromDistinctAscList . zip [0 ..] $ combineList w)
"COMBINATIONS"
$ w ^? hud . hudElement . subInventory . ciFilter . _Just
$ w ^? hud . subInventory . ciFilter . _Just
invitms = _unNIntMap $ fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ fold $ w ^? cWorld . lWorld . creatures . ix 0 . crInv
sclose'
| null sclose =
@@ -87,24 +87,24 @@ orRegex f x str = case words str of
updateInventoryPositioning :: Universe -> Universe
updateInventoryPositioning u =
u & uvWorld . hud . hudElement . diSections
u & uvWorld . hud . diSections
%~ updateDisplaySections (_uvWorld u) (_uvConfig u)
& uvWorld
%~ checkInventorySelectionExists
checkInventorySelectionExists :: World -> World
checkInventorySelectionExists w
| isJust $ w ^? hud . hudElement . diSections . ix i . ssItems . ix j = w
| isJust $ w ^? hud . diSections . ix i . ssItems . ix j = w
| otherwise = scrollAugNextInSection w
where
(i, j, _) = fromMaybe (1, -1, mempty) $ w ^? hud . hudElement . diSelection . _Just
Sel i j _ = fromMaybe (Sel 1 (-1) mempty) $ w ^? hud . diSelection . _Just
checkCombineSelectionExists :: SubInventory -> SubInventory
checkCombineSelectionExists si
| Just sss <- si ^? ciSections
, Just (i, j, _) <- si ^? ciSelection . _Just <|> Just (0, 0, mempty)
, Sel i j _ <- fromMaybe (Sel 0 0 mempty) $ si ^? ciSelection . _Just
, isNothing $ si ^? ciSections . ix i . ssItems . ix j =
si & ciSelection ?~ (0, -1, mempty)
si & ciSelection ?~ Sel 0 (-1) mempty
& ciSelection
%~ scrollSelectionSections (-1) sss
| otherwise = si
@@ -115,7 +115,7 @@ displayIndents 3 = 2
displayIndents 5 = 2
displayIndents _ = 0
updateDisplaySections :: World -> Configuration -> IMSS () -> IMSS ()
updateDisplaySections :: World -> Config -> IMSS () -> IMSS ()
updateDisplaySections w cfig =
updateSectionsPositioning
displayIndents
@@ -135,15 +135,15 @@ updateDisplaySections w cfig =
]
)
where
mselpos = w ^? hud . hudElement . diSelection . _Just
invfiltcurs = mselpos ^? _Just . _1 == Just (-1)
mselpos = w ^? hud . diSelection . _Just
invfiltcurs = mselpos ^? _Just . slSec == Just (-1)
(sfinv, sinv) =
filterSectionsPair invfiltcurs plainRegex invitems "INVENTORY" $
w ^? hud . hudElement . diInvFilter . _Just
closefiltcurs = mselpos ^? _Just . _1 == Just 2
w ^? hud . diInvFilter . _Just
closefiltcurs = mselpos ^? _Just . slSec == Just 2
(sfclose, sclose) =
filterSectionsPair closefiltcurs plainRegex closeitms "NEARBY ITEMS" $
w ^? hud . hudElement . diCloseFilter . _Just
w ^? hud . diCloseFilter . _Just
nearbyhead
| null sfclose && not (null sclose) = makehead "NEARBY ITEMS"
| otherwise = sfclose
@@ -156,11 +156,11 @@ updateDisplaySections w cfig =
cr = you w
closeitms =
IM.fromDistinctAscList . zip [0 ..] $
mapMaybe (closeItemToSelectionItem w) (map _unNInt $ w ^. hud . closeItems)
mapMaybe (closeItemToSelectionItem w . _unNInt) (w ^. hud . closeItems)
invitems =
IM.map
(uncurry (invSelectionItem w))
(invIndents $ fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ _crInv cr)
(invIndents $ (\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr)
filterSectionsPair ::
Bool -> -- check for whether filter is in focus, changes string at the end
@@ -241,7 +241,7 @@ doSectionSize extraavailable mintaken is sss done = fromMaybe done $ do
updateSectionsPositioning ::
(Int -> Int) -> -- for determining each sections indent
Maybe (Int, Int, IntSet) ->
Maybe Selection ->
Int ->
IM.IntMap (IM.IntMap (SelectionItem a)) ->
IM.IntMap (SelectionSection a) ->
@@ -251,13 +251,13 @@ updateSectionsPositioning h mselpos allavailablelines lsss sss =
where
offsets = fmap _ssOffset sss
m k = do
(k', i, _) <- mselpos
Sel k' i _ <- mselpos
guard $ k == k'
return i
ls = lsss
-- defaults non-existing offsets to 0
g = merge (mapMissing (const ($ 0))) dropMissing (zipWithMatched (const ($)))
lk = mselpos ^.. _Just . _1
lk = mselpos ^.. _Just . slSec
ssizes = sectionsSizes allavailablelines lk $ sectionsDesiredLines ls
updateSection ::
@@ -315,16 +315,16 @@ regexList = any . List.isInfixOf
toggleCombineInv :: Universe -> Universe
toggleCombineInv uv =
uv & case uv ^? uvWorld . hud . hudElement . subInventory of
Just CombineInventory{} -> uvWorld . hud . hudElement . subInventory .~ NoSubInventory
uv & case uv ^? uvWorld . hud . subInventory of
Just CombineInventory{} -> uvWorld . hud . subInventory .~ NoSubInventory
_ -> uvWorld %~ enterCombineInv (uv ^. uvConfig)
enterCombineInv :: Configuration -> World -> World
enterCombineInv :: Config -> World -> World
enterCombineInv cfig w =
w & hud . hudElement . subInventory
w & hud . subInventory
.~ CombineInventory
{ _ciSections = updateCombineSections w cfig mempty
, _ciSelection = Just (0,0,mempty)
, _ciSelection = Just (Sel 0 0 mempty)
, _ciFilter = Nothing
}
& hud . hudElement . diInvFilter .~ Nothing
& hud . diInvFilter .~ Nothing
src/Dodge/Equipment.hs
+12 -11
View File
@@ -6,8 +6,6 @@ module Dodge.Equipment (
import Control.Lens
import Data.Maybe
import Dodge.Creature.HandPos
import Dodge.Creature.Test
import Dodge.Data.Equipment.Misc
import Dodge.Data.World
import Dodge.Item.Location
import Dodge.Wall.Delete
@@ -15,6 +13,7 @@ import Dodge.Wall.ForceField
import Dodge.Wall.Move
import Geometry
import qualified IntMapHelp as IM
import NewInt
effectOnRemove :: Item -> Creature -> World -> World
effectOnRemove itm = case itm ^. itType of
@@ -50,13 +49,15 @@ setWristShieldPos :: Item -> Creature -> World -> World
setWristShieldPos itm cr w = w & moveWallIDUnsafe i wlline
where
i = _itParamID $ _itParams itm
m = w ^. cWorld . lWorld . items
wlline = (f (V3 (-10) 7 0), f (V3 10 7 0))
invid = _ilInvID (_itLocation itm)
handtrans = case cr ^? crInv . ix invid >>= \k -> w ^? cWorld . lWorld . items . ix k . itLocation . ilEquipSite . _Just of
Just OnLeftWrist -> \cr' -> translatePointToLeftHand m cr' . g
_ -> translatePointToRightHand m
g
| twists m cr = (+.+.+ V3 (-5) 10 0)
| otherwise = id
f = (+.+ _crPos cr) . stripZ . rotate3 (_crDir cr) . handtrans cr
handtrans = case w ^? cWorld . lWorld . items
. ix (itm ^. itID . unNInt)
. itLocation
. ilEquipSite
. _Just of
Just x -> translateToES cr x -- . g
_ -> undefined
-- g
-- | twists cr = (+.+.+ V3 (-5) 10 0)
-- | otherwise = id
f = (+.+ _crPos cr) . stripZ . rotate3 (_crDir cr) . handtrans
src/Dodge/Equipment/Text.hs
+2 -3
View File
@@ -9,6 +9,5 @@ eqPosText ep = case ep of
OnBack -> "BACK"
OnLeftWrist -> "L.WRIST"
OnRightWrist -> "R.WRIST"
OnLegs -> "LEGS"
-- OnSpecial -> "EQUIPPED"
OnLeftLeg -> "L.LEG"
OnRightLeg -> "R.LEG"
src/Dodge/Euse.hs
+5 -6
View File
@@ -33,16 +33,15 @@ useMagShield mt _ cr w =
}
setWristShieldPos :: Item -> Creature -> EquipSite -> World -> World
setWristShieldPos itm cr x w = moveWallIDUnsafe i wlline w
setWristShieldPos itm cr x = moveWallIDUnsafe i wlline
where
m = w ^. cWorld . lWorld . items
i = _itParamID $ _itParams itm
wlline = (f (V3 (-10) 7 0), f (V3 10 7 0))
handtrans = case x of
OnLeftWrist -> \cr' -> translatePointToLeftHand m cr' . g
_ -> translatePointToRightHand m
OnLeftWrist -> \cr' -> translatePointToLeftHand cr' . g
_ -> translatePointToRightHand
g
| twists m cr = (+.+.+ V3 (-5) 10 0)
| twists cr = (+.+.+ V3 (-5) 10 0)
| otherwise = id
f = (+.+ _crPos cr) . stripZ . rotate3 (_crDir cr) . handtrans cr
@@ -58,6 +57,6 @@ createHeadLamp _ cr w = w &
cWorld . lWorld . lights
.:~ LSParam
((_crPos cr `v2z` 0) +.+.+ rotate3 (_crDir cr)
(translatePointToHead (w ^. cWorld . lWorld . items) cr (V3 5 0 3)))
(translateToES cr OnHead (V3 5 0 3)))
200
0.7
src/Dodge/Event/Input.hs
+1 -1
View File
@@ -44,7 +44,7 @@ scToTS = \case
ScancodeDown -> Just TSdown
_ -> Nothing
handleMouseMotionEvent :: MouseMotionEventData -> Configuration -> Input -> Input
handleMouseMotionEvent :: MouseMotionEventData -> Config -> Input -> Input
handleMouseMotionEvent mmev cfig = set mousePos themousepos . set mouseMoving True
where
P (V2 x y) = mouseMotionEventPos mmev
src/Dodge/Floor.hs
+3 -4
View File
@@ -4,8 +4,8 @@ module Dodge.Floor (
tutRoomTree,
) where
import Dodge.Room.Tutorial
import Dodge.Annotation.Data
--import Dodge.Room.Tutorial
import Data.List (intersperse)
import Dodge.Annotation
import Dodge.Cleat
@@ -24,8 +24,7 @@ initialRoomTree = annoToRoomTree initialAnoTree
--initialRoomTree = annoToRoomTree startWorldTreeTest
tutRoomTree :: State LayoutVars (MetaTree Room String)
--tutRoomTree = annoToRoomTree tutAnoTree
tutRoomTree = annoToRoomTree initialAnoTree
tutRoomTree = annoToRoomTree tutAnoTree
--startWorldTreeTest :: Annotation
--startWorldTreeTest =
@@ -129,4 +128,4 @@ intAnno f = do
zoom lyGen (f i)
anRoom :: State StdGen Room -> Annotation
anRoom t = AnTree $ zoom lyGen $ (tToBTree "anRoom" . return . cleatOnward <$> t)
anRoom t = AnTree $ zoom lyGen (tToBTree "anRoom" . return . cleatOnward <$> t)
src/Dodge/HeldUse.hs
+67 -80
View File
@@ -160,14 +160,7 @@ locMuzzles loc
itemMuzzles :: Item -> [Muzzle]
itemMuzzles itm = case itm ^. itType of
HELD ALTERIFLE ->
dbwMuzzles & ix 0 . mzPos .~ V2 25 0
& ix 0 . mzAmmoSlot .~ MagBelow (_alteRifleSwitch (_itParams itm)) (UseExactly 1)
HELD (VOLLEYGUN i) -> fromMaybe [] $ do
j <- itm ^? itParams . unfiredBarrels . ix 0
x <- vgunMuzzles i ^? ix j
return [x]
HELD hit -> heldItemMuzzles hit
HELD hit -> heldItemMuzzles itm hit
DETECTOR{} ->
dbwMuzzles & ix 0 . mzEffect .~ MuzzleDetector
& ix 0 . mzAmmoSlot . aps .~ UseExactly 100
@@ -179,8 +172,15 @@ itemMuzzles itm = case itm ^. itType of
& ix 0 . mzEffect .~ MuzzleLaser
_ -> []
heldItemMuzzles :: HeldItemType -> [Muzzle]
heldItemMuzzles = \case
heldItemMuzzles :: Item -> HeldItemType -> [Muzzle]
heldItemMuzzles itm = \case
ALTERIFLE ->
dbwMuzzles & ix 0 . mzPos .~ V2 25 0
& ix 0 . mzAmmoSlot .~ MagBelow (_alteRifleSwitch (_itParams itm)) (UseExactly 1)
(VOLLEYGUN i) -> fromMaybe [] $ do
j <- itm ^? itParams . unfiredBarrels . ix 0
x <- vgunMuzzles i ^? ix j
return [x]
BANGSTICK i ->
[ Muzzle
(V2 10 0)
@@ -201,6 +201,7 @@ heldItemMuzzles = \case
AUTOPISTOL -> [Muzzle (V2 10 0) 0 0 maguse1 BasicFlare MuzzleShootBullet 0]
SMG -> [Muzzle (V2 20 0) 0 0.05 maguse1 BasicFlare MuzzleShootBullet 0]
RIFLE -> dbwMuzzles & ix 0 . mzPos .~ V2 25 0
AUTORIFLE -> dbwMuzzles & ix 0 . mzPos .~ V2 25 0
BURSTRIFLE -> dbwMuzzles & ix 0 . mzPos .~ V2 25 0 & ix 0 . mzInaccuracy .~ 0.05
MINIGUNX i ->
replicate
@@ -235,7 +236,6 @@ heldItemMuzzles = \case
BLUNDERBUSS -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet 12]
GRAPECANNON i -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet (12 + 4 * fromIntegral i)]
TORCH -> dbwMuzzles & ix 0 . mzPos .~ V2 10 0
VOLLEYGUN{} -> error "should get volleygun muzzles earlier"
FLAMETHROWER -> flameMuzzles
FLAMESPITTER -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 3 4
RLAUNCHER ->
@@ -444,7 +444,7 @@ applySoundCME itm cr = fromMaybe id $ do
return $
if x > 0
then soundContinue (CrWeaponSound cid 0) (_crPos cr) soundid (Just x)
else soundMultiFrom [CrWeaponSound cid j | j <- [0 .. 5]] (_crPos cr) soundid Nothing
else soundMultiFrom [CrWeaponSound cid j | j <- [0 .. 16]] (_crPos cr) soundid Nothing
where
cid = _crID cr
@@ -620,26 +620,30 @@ heldTorqueAmount = \case
-- fugly
loadMuzzle :: LocationDT OItem -> Creature -> (Bool, World) -> Muzzle -> (Bool, World)
loadMuzzle loc cr (b, w) mz = maybe (b, w) (True,) $ do
case mz ^. mzAmmoSlot of
NoAmmoRequired -> return (useLoadedAmmo loc cr mz Nothing w)
as -> do
mag <- case as of
MagBelow mi _ -> find (isAmmoIntLink mi . (^. dtValue . _2)) (loc ^. locDT . dtLeft)
CapacitorSelf _ -> loc ^? locDT
CapacitorBelow _ ->
find
((== PulseBallSF) . (^. dtValue . _2))
(loc ^. locDT . dtLeft)
mid <- mag ^? dtValue . _1 . itID . unNInt
availableammo <- w ^? cWorld . lWorld . items . ix mid . itConsumables . _Just
let usedammo = case as ^?! aps of
UseUpTo x -> min x availableammo
UseExactly x
| x <= availableammo -> x
| otherwise -> 0
guard $ usedammo > 0
return $ useLoadedAmmo loc cr mz (Just (usedammo, mag)) w
loadMuzzle loc cr (b, w) mz = maybe (b, w) (True,) $ case mz ^. mzAmmoSlot of
NoAmmoRequired -> return (useLoadedAmmo loc cr mz Nothing w)
as -> do
mag <- case as of
MagBelow mi _ ->
find
(isAmmoIntLink mi . (^. dtValue . _2))
(loc ^. locDT . dtLeft)
CapacitorSelf _ -> loc ^? locDT
CapacitorBelow _ ->
find
((== PulseBallSF) . (^. dtValue . _2))
(loc ^. locDT . dtLeft)
mid <- mag ^? dtValue . _1 . itID . unNInt
availableammo <- w ^? cWorld . lWorld . items . ix mid . itConsumables . _Just
let usedammo = case as ^?! aps of
UseUpTo x -> min x availableammo
UseExactly x
| x <= availableammo -> x
| otherwise -> 0
guard $ usedammo > 0
return $
useLoadedAmmo loc cr mz (Just (usedammo, mag)) $
removeAmmoFromMag usedammo mid w
makeMuzzleFlare :: Muzzle -> LocationDT OItem -> Creature -> World -> World
makeMuzzleFlare mz loc cr = case mz ^. mzFlareType of
@@ -668,12 +672,11 @@ makeMuzzleFlare mz loc cr = case mz ^. mzFlareType of
--{-# OPTIONS -Wno-incomplete-uni-patterns #-}
muzFlareAt :: Color -> Point3 -> Float -> World -> World
muzFlareAt col tranv dir w =
w & randGen .~ g
& cWorld . lWorld . flares <>~ thepic
muzFlareAt col x dir w =
w & randGen .~ g & cWorld . lWorld . flares <>~ thepic
where
thepic =
setLayer BloomLayer . translate3 tranv . color col . rotate dir . polygon $
setLayer BloomLayer . translate3 x . color col . rotate dir . polygon $
[ V2 0 0
, V2 a (- b)
, V2 c d
@@ -718,7 +721,7 @@ useLoadedAmmo ::
World ->
World
useLoadedAmmo loc cr mz m w =
removeAmmoFromMag m . makeMuzzleFlare mz loc cr $ case _mzEffect mz of
makeMuzzleFlare mz loc cr $ case _mzEffect mz of
MuzzleShootBullet -> shootBullets loc cr (mz, x, magtree) w
MuzzleLaser -> creatureShootLaser loc cr mz w
MuzzlePulseLaser -> creatureShootPulseLaser loc cr mz w
@@ -735,7 +738,7 @@ useLoadedAmmo loc cr mz m w =
mz
cr
w
MuzzleNozzle{} -> useGasParams mid mz loc cr $ walkNozzle mz itm w
MuzzleNozzle{} -> useGasParams mitid mz loc cr $ walkNozzle mz itm w
MuzzleShatter -> shootShatter itm cr w
MuzzleDetector ->
itemDetectorEffect
@@ -751,7 +754,7 @@ useLoadedAmmo loc cr mz m w =
MuzzleScroller -> useTimeScrollGun itm cr w
where
itmtree = loc ^. locDT
mid = magtree ^? dtValue . _1 . itLocation . ilInvID
mitid = magtree ^. dtValue . _1 . itID
itm = itmtree ^. dtValue . _1
(x, magtree) = fromJust m
@@ -779,11 +782,7 @@ itemDetectorEffect itm mitid armitid cr w = fromMaybe w $ do
walkNozzle :: Muzzle -> Item -> World -> World
walkNozzle mz itm w =
w
& cWorld . lWorld . items
. ix (itm ^. itID . unNInt)
. itParams
. nzAngle
%~ f
& cWorld . lWorld . items . ix (itm ^. itID . unNInt) . itParams . nzAngle %~ f
& randGen .~ g
where
nz = _mzEffect mz
@@ -918,17 +917,9 @@ shootPulseBall p dir w =
where
i = IM.newKey $ w ^. cWorld . lWorld . pulseBalls
--removeAmmoFromMag :: Int -> Maybe Int -> Creature -> World -> World
removeAmmoFromMag :: Maybe (Int, DTree OItem) -> World -> World
removeAmmoFromMag m = fromMaybe id $ do
(x, magtree) <- m
magid <- magtree ^? dtValue . _1 . itID . unNInt
return $
cWorld . lWorld . items
. ix magid
. itConsumables
. _Just
-~ x
removeAmmoFromMag :: Int -> Int -> World -> World
removeAmmoFromMag x magid =
cWorld . lWorld . items . ix magid . itConsumables . _Just -~ x
getBulletType :: DTree OItem -> Maybe Bullet
getBulletType magtree =
@@ -1118,9 +1109,14 @@ mcUseHeld hit = case hit of
LASER -> mcShootLaser
_ -> mcShootAuto
useGasParams :: Maybe (NewInt InvInt)
-> Muzzle -> LocationDT OItem -> Creature -> World -> World
useGasParams mmagid mz loc cr w =
useGasParams ::
NewInt ItmInt ->
Muzzle ->
LocationDT OItem ->
Creature ->
World ->
World
useGasParams (NInt magitid) mz loc cr w =
w
& createGas gastype pressure pos dir cr
& randGen .~ g'
@@ -1128,9 +1124,8 @@ useGasParams mmagid mz loc cr w =
itm = loc ^. locDT . dtValue . _1
(pressure, g) = doGenFloat (_nzPressure $ _mzEffect mz) (_randGen w)
gastype = fromMaybe (error "cannot find gas ammo") $ do
magid <- mmagid
hit <- itm ^? itType . ibtHeld
fueltype <- cr ^? crInv . ix magid >>= \k -> w ^? cWorld . lWorld . items . ix k >>= magAmmoParams >>= (^? ampCreateGas)
fueltype <- w ^? cWorld . lWorld . items . ix magitid >>= magAmmoParams >>= (^? ampCreateGas)
gasType hit fueltype
(V3 x y _, q) =
locOrient loc cr
@@ -1319,25 +1314,17 @@ createProjectile ::
Creature ->
World ->
World
createProjectile x pjtype magtree stab muz cr w =
w
& ( fromMaybe failsound $ do
magid <- magtree ^? dtValue . _1 . itLocation . ilInvID
ammoitem <- cr ^? crInv . ix magid >>= \k -> w ^? cWorld . lWorld . items . ix k
let rdetonate =
(^. dtValue . _1 . itID)
<$> find isrdet (magtree ^. dtLeft)
rscreen =
(^. dtValue . _1 . itID)
<$> find isrscreen (magtree ^. dtLeft)
aparams <-
((magtree ^? dtLeft) >>= find isampay >>= (^? dtValue . _1 . itType . ibtAttach . shellPayload))
-- <|> ammoitem ^? itConsumables . magParams . ampPayload
<|> magAmmoParams ammoitem ^? _Just . ampPayload
return $
createShell x rdetonate rscreen stab pjtype aparams muz cr
. startthesound
)
createProjectile x pjtype mtree stab muz cr w = fromMaybe (failsound w) $ do
magitid <- mtree ^? dtValue . _1 . itID . unNInt
ammoitem <- w ^? cWorld . lWorld . items . ix magitid
let rdetonate =
(^. dtValue . _1 . itID) <$> find isrdet (mtree ^. dtLeft)
rscreen =
(^. dtValue . _1 . itID) <$> find isrscreen (mtree ^. dtLeft)
aparams <-
((mtree ^? dtLeft) >>= find isampay >>= (^? dtValue . _1 . itType . ibtAttach . shellPayload))
<|> magAmmoParams ammoitem ^? _Just . ampPayload
return . makesound $ createShell x rdetonate rscreen stab pjtype aparams muz cr w
where
isrdet :: DTree OItem -> Bool
isrdet y = case y ^. dtValue . _2 of
@@ -1353,7 +1340,7 @@ createProjectile x pjtype magtree stab muz cr w =
_ -> False
-- the sound should be moved to the projectile firing
startthesound =
makesound =
soundMultiFrom
[CrWeaponSound (_crID cr) j | j <- [0 .. 3]]
(_crPos cr)
src/Dodge/InputFocus.hs
+14 -19
View File
@@ -6,27 +6,22 @@ import Dodge.Data.World
import LensHelp
inTextInputFocus :: World -> Bool
inTextInputFocus = isJust . inputFocusI
inTextInputFocus = isJust . textInputFocus
inputFocusI :: World -> Maybe ((String -> Identity String) -> World -> Identity World)
inputFocusI = textInputFocus
textInputFocus ::
Applicative f =>
World ->
Maybe ((String -> f String) -> World -> f World)
textInputFocus w = case w ^? hud . hudElement . subInventory of
Just NoSubInventory{} -> case he ^? diSelection . _Just . _1 of
Just (-1) -> Just $ hud . hudElement . diInvFilter . _Just
Just 2 -> Just $ hud . hudElement . diCloseFilter . _Just
textInputFocus :: World -> Maybe ((String -> Identity String) -> World -> Identity World)
textInputFocus w = case w ^. hud . subInventory of
NoSubInventory{} -> case he ^? diSelection . _Just . slSec of
Just (-1) -> Just $ hud . diInvFilter . _Just
Just 2 -> Just $ hud . diCloseFilter . _Just
_ -> Nothing
Just CombineInventory{} -> case he ^? subInventory . ciSelection . _Just . _1 of
Just (-1) -> Just $ hud . hudElement . subInventory . ciFilter . _Just
CombineInventory{} -> case he ^? subInventory . ciSelection . _Just . slSec of
Just (-1) -> Just $ hud . subInventory . ciFilter . _Just
_ -> Nothing
Just DisplayTerminal{_termID = tmid} -> do
-- connectionstatus <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus
-- guard $ connectionstatus == TerminalTextInput
return $ cWorld . lWorld . terminals . ix tmid . tmStatus . tiText
DisplayTerminal{_termID = tmid} -> case w ^? cWorld . lWorld . terminals . ix tmid . tmStatus . tiText of
Just _ -> return $ cWorld . lWorld . terminals . ix tmid . tmStatus . tiText
Nothing -> Nothing
-- DisplayTerminal{_termID = tmid} -> return
-- $ cWorld . lWorld . terminals . ix tmid . tmStatus . tiText
_ -> Nothing
where
he = w ^. hud . hudElement
he = w ^. hud
src/Dodge/Inventory.hs
+22 -46
View File
@@ -17,7 +17,6 @@ module Dodge.Inventory (
) where
import Data.Function
import qualified Data.IntSet as IS
import Data.Maybe
import Dodge.Base
import Dodge.Data.SelectionList
@@ -38,9 +37,7 @@ import NewInt
-- should consider never fully destroying items, but assigning a flag saying how
-- they were moved from play
destroyInvItem :: Int -> NewInt InvInt -> World -> World
destroyInvItem cid invid w =
rmInvItem cid invid w & removeitloc
& removeithotkey
destroyInvItem cid invid w = rmInvItem cid invid w & removeitloc & removeithotkey
where
removeitloc = fromMaybe id $ do
itid <- w ^? cWorld . lWorld . creatures . ix cid . crInv . ix invid
@@ -79,7 +76,7 @@ rmInvItem cid invid w =
& dounequipfunction --the ordering of these is
& pointcid . crInv %~ f -- important
& removeAnySlotEquipment
& pointcid . crEquipment . each %~ g
& cWorld . lWorld . items . ix itid . itLocation . ilEquipSite .~ Nothing
& updateselection
& updateselectionextra
& pointcid %~ updateRootItemID (w ^. cWorld . lWorld . items)
@@ -87,7 +84,7 @@ rmInvItem cid invid w =
where
pointcid = cWorld . lWorld . creatures . ix cid
updateselectionextra
| cid == 0 = hud . hudElement . diSelection . _Just . _3 %~ const mempty
| cid == 0 = hud . diSelection . _Just . slSet %~ const mempty
| otherwise = id
updateselection
| cid == 0 && cr ^? crManipulation . manObject . imSelectedItem == Just invid =
@@ -98,18 +95,13 @@ rmInvItem cid invid w =
itid = _crInv cr ^?! ix invid
itm = w ^?! cWorld . lWorld . items . ix itid
dounequipfunction = effectOnRemove itm cr
-- fromMaybe id $ do
-- rmf <- itm ^? itUse . uequipEffect . eeOnRemove
-- return $ doItmCrWdWd rmf itm cr
removeAnySlotEquipment = fromMaybe id $ do
epos <-
w
^? cWorld . lWorld . creatures . ix cid . crInv . ix invid
>>= \k -> w ^? cWorld . lWorld . items . ix k
. itLocation
epos <- itm ^?
itLocation
. ilEquipSite
. _Just
return $ pointcid . crEquipment . at epos .~ Nothing
-- return $ pointcid . crEquipment .~ mempty
maxk = fmap fst $ IM.lookupMax $ _unNIntMap $ cr ^. crInv
f inv =
let (xs, ys) = IM.split (_unNInt invid) $ _unNIntMap inv
@@ -121,23 +113,22 @@ rmInvItem cid invid w =
updateCloseObjects :: World -> World
updateCloseObjects w =
w & hud . closeItems %~ f
& hud . closeButtons %~ g
w & hud . closeItems %~ h citems
& hud . closeButtons %~ h cbts
where
g oldbts = intersect oldbts cbts `union` cbts
f olditems = intersect olditems citems `union` citems
h a b = intersect b a `union` a
lw = w ^. cWorld . lWorld
citems = let is = IM.filter (isclose . _flItPos) (lw^.floorItems)
in map NInt $ IM.keys $ IM.intersection (lw ^. items) is
isclose x = dist y x < 40 && hasButtonLOS y x w
y = _crPos $ you w
citems = map NInt $ IM.keys $ IM.intersection (lw ^. items)
$ IM.filter (isclose . _flItPos) (lw^.floorItems)
cbts = lw^..buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
canpress bt = case bt ^. btEvent of
ButtonPress{_btOn = t} -> not t
ButtonAccessTerminal tid -> fromMaybe False $ do
x <- w ^? cWorld . lWorld . terminals . ix tid . tmStatus
x <- lw ^? terminals . ix tid . tmStatus
return (x /= TerminalDeactivated)
_ -> True
isclose x = dist y x < 40 && hasButtonLOS y x w
y = _crPos $ you w
changeSwapSel :: Int -> World -> World
changeSwapSel yi w
@@ -154,7 +145,7 @@ changeSwapOther ::
World ->
World
changeSwapOther manlens n f i w = fromMaybe w $ do
ss <- w ^? hud . hudElement . diSections . ix n . ssItems
ss <- w ^? hud . diSections . ix n . ssItems
k <- f i ss
let doswap j
| j == i = k
@@ -166,7 +157,7 @@ changeSwapOther manlens n f i w = fromMaybe w $ do
& cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . manlens
%~ doswap
& hud . closeItems %~ swapIndices i k
& hud . hudElement . diSelection . _Just . _2 %~ doswap
& hud . diSelection . _Just . slInt %~ doswap
& worldEventFlags . at InventoryChange ?~ ()
swapItemWith ::
@@ -182,40 +173,25 @@ swapItemWith f (j, i) = case j of
changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
changeSwapWith f w
| Just (j,i,_) <- w ^. hud . hudElement . diSelection = swapItemWith f (j,i) w
| Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j,i) w
| otherwise = w
--changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
--changeSwapWith f w = case w ^? hud . hudElement . diSelection . _Just of
-- Just (0, i, _) -> w & swapInvItems f i
-- Just (3, i, _) -> w & changeSwapOther ispCloseItem 3 f i
-- Just (5, i, _) -> w & changeSwapOther ispCloseButton 5 f i
-- _ -> w
invSetSelection :: (Int, Int, IS.IntSet) -> World -> World
invSetSelection :: Selection -> World -> World
invSetSelection sel w =
w
& hud . hudElement . diSelection ?~ sel
& hud . diSelection ?~ sel
& worldEventFlags . at InventoryChange ?~ ()
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0
invSetSelectionPos :: Int -> Int -> World -> World
invSetSelectionPos i j w =
w
& hud . hudElement . diSelection %~ f
& worldEventFlags . at InventoryChange ?~ ()
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0
where
f Nothing = Just (i, j, mempty)
f (Just (_, _, s)) = Just (i, j, s)
invSetSelectionPos i j = invSetSelection (Sel i j mempty)
scrollAugInvSel :: Int -> World -> World
scrollAugInvSel yi w
| yi == 0 = w
| otherwise =
w & hud . hudElement %~ doscroll
w & hud %~ doscroll
& worldEventFlags . at InventoryChange ?~ ()
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0
@@ -226,7 +202,7 @@ scrollAugInvSel yi w
scrollAugNextInSection :: World -> World
scrollAugNextInSection w =
w & hud . hudElement %~ doscroll
w & hud %~ doscroll
& worldEventFlags . at InventoryChange ?~ ()
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0
src/Dodge/Inventory/Add.hs
+2 -2
View File
@@ -19,7 +19,6 @@ import Dodge.SoundLogic
import qualified IntMapHelp as IM
import NewInt
-- should check that the item is not already in your inventory
-- this assumes that this item is currently on the floor
tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt, World)
tryPutItemInInv cid itid w = do
@@ -43,7 +42,8 @@ tryPutItemInInv cid itid w = do
& updateselectionextra invid
where
updateselectionextra i
| cid == 0 = hud . hudElement . diSelection . _Just . _3 %~ IS.map (f i)
| cid == 0 = (hud . diSelection . _Just . slSet %~ IS.map (f i))
. (hud . diSelection . _Just . slInt %~ f i)
| otherwise = id
f j i | i >= _unNInt j = i + 1
| otherwise = i
src/Dodge/Inventory/Location.hs
+9 -12
View File
@@ -4,7 +4,6 @@ module Dodge.Inventory.Location (
setInvPosFromSS,
) where
import Control.Applicative
import Control.Lens
import Data.Foldable
--import Data.IntMap.Merge.Strict
@@ -32,16 +31,17 @@ tryGetRootAttachedFromInvID (NInt invid) im = do
-- this assumes the creature inventory is well formed, specifically the
-- location ids
tryGetRootItemInvID :: IM.IntMap Item -> Int -> Creature -> Maybe Int
tryGetRootItemInvID m i cr = do
-- note the item intmap is all items
getRootItemInvID :: IM.IntMap Item -> Int -> Creature -> Int
getRootItemInvID m i cr = fromMaybe i $ do
let adj = invAdj $ fmap (\k -> m ^?! ix k) (_crInv cr)
theroot <- adj ^? ix i
theroot ^? _1 . _Just . _1 <|> Just i
theroot ^? _1 . _Just . _1
updateRootItemID :: IM.IntMap Item -> Creature -> Creature
updateRootItemID m cr = fromMaybe cr $ do
i <- cr ^? crManipulation . manObject . imSelectedItem . unNInt
j <- tryGetRootItemInvID m i cr
let j = getRootItemInvID m i cr
return $ cr & crManipulation . manObject . imRootSelectedItem .~ NInt j
-- the following assumes that the crManipulation is correct
@@ -49,7 +49,6 @@ crUpdateItemLocations :: Int -> LWorld -> LWorld
crUpdateItemLocations crid lw = fromMaybe lw $ do
mo <- lw ^? creatures . ix crid . crManipulation . manObject
cinv <- lw ^? creatures . ix crid . crInv
--let crinv = IM.restrictKeys (lw ^. items) (IS.fromList $ IM.elems itids)
let crinv = fmap (\k -> lw ^?! items . ix k) cinv
return $ crSetRoots crid $ IM.foldlWithKey' (crUpdateInvidLocations mo crid) lw $ _unNIntMap crinv
@@ -62,8 +61,7 @@ crSetRoots cid w = fromMaybe w $ do
g w' i = w' & items . ix i . itLocation . ilIsRoot .~ False
f :: LWorld -> DTree OItem -> LWorld
f w' x =
w'
& items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
w' & items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
crUpdateInvidLocations ::
ManipulatedObject ->
@@ -74,7 +72,7 @@ crUpdateInvidLocations ::
LWorld
crUpdateInvidLocations mo crid lw invid itm =
lw
& creatures . ix crid . crInv . ix (NInt invid) .~ itid -- . itLocation .~ newloc
& creatures . ix crid . crInv . ix (NInt invid) .~ itid
& items . ix itid .~ (itm & itLocation .~ newloc)
where
itid = itm ^. itID . unNInt
@@ -85,8 +83,7 @@ crUpdateInvidLocations mo crid lw invid itm =
, _ilIsRoot = Just (NInt invid) == mo ^? imRootSelectedItem
, _ilIsSelected = Just (NInt invid) == mo ^? imSelectedItem
, _ilIsAttached = invid `IS.member` (mo ^. imAttachedItems)
, _ilEquipSite = do
lw ^? items . ix itid . itLocation . ilEquipSite . _Just
, _ilEquipSite = lw ^? items . ix itid . itLocation . ilEquipSite . _Just
}
-- this should be looked at, as it is sometimes used in functions that need not
@@ -97,7 +94,7 @@ setInvPosFromSS w = w
& cWorld . lWorld . creatures . ix 0 . crManipulation . manObject .~ thesel
where
thesel = fromMaybe SelNothing $ do
(i, j, _) <- w ^? hud . hudElement . diSelection . _Just
Sel i j _ <- w ^? hud . diSelection . _Just
case i of
(-1) -> Just SortInventory
0 -> do
src/Dodge/Inventory/RBList.hs
+46 -49
View File
@@ -1,86 +1,83 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Inventory.RBList (
updateRBList,
getEquipmentAllocation,
eqSiteToPositions,
equipmentDesignation,
eqTypeToSites,
) where
import NewInt
import qualified Data.IntMap.Strict as IM
import Dodge.Data.Equipment.Misc
import Dodge.Data.EquipType
import Control.Applicative
--import qualified Data.IntMap.Strict as IM
--import Control.Applicative
import Control.Lens
import Data.List (elemIndex, findIndex)
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Base.You
import Dodge.Data.EquipType
import Dodge.Data.World
import NewInt
import qualified SDL
updateRBList :: World -> World
updateRBList w = case w ^. rbOptions of
_ | norightclick -> w & rbOptions .~ NoRightButtonOptions
updateRBList w = case w ^. rbState of
_ | norightclick -> w & rbState .~ NoRightButtonState
EquipOptions{} -> w
_ -> fromMaybe (w & rbOptions .~ NoRightButtonOptions) $ do
_ -> fromMaybe (w & rbState .~ NoRightButtonState) $ do
i <- cr ^? crManipulation . manObject . imSelectedItem
esite <- cr ^? crInv . ix i >>= \k -> w ^? cWorld . lWorld . items . ix k >>= equipType -- . itUse . uequipEffect . eeType
itid <- cr ^? crInv . ix i
itm <- w ^? cWorld . lWorld . items . ix itid
etype <- equipType itm
return $
w & rbOptions
.~ EquipOptions
{ _opSel = chooseEquipPosition (w ^. cWorld . lWorld . items) cr (eqSiteToPositions esite)
}
w & rbState
.~ EquipOptions (chooseEquipPosition itm cr (eqTypeToSites etype))
where
norightclick = not $ SDL.ButtonRight `M.member` (w ^. input . mouseButtons)
--norightclick = not $ SDL.ButtonRight `M.member` (w ^. input . mouseButtons)
norightclick = null $ w ^. input . mouseButtons . at SDL.ButtonRight
cr = you w
-- want to choose the current position if the item is equipped, otherwise try to
-- find a free equipment slot
chooseEquipPosition :: IM.IntMap Item -> Creature -> [EquipSite] -> Int
chooseEquipPosition m cr eps = fromMaybe (chooseFreeSite cr eps) $ do
i <- cr ^? crManipulation . manObject . imSelectedItem
itid <- cr ^? crInv . ix i
ep <- m ^? ix itid . itLocation . ilEquipSite . _Just
chooseEquipPosition :: Item -> Creature -> [EquipSite] -> Int
chooseEquipPosition itm cr eps = fromMaybe (chooseFreeSite cr eps) $ do
ep <- itm ^? itLocation . ilEquipSite . _Just
elemIndex ep eps
-- (elemIndex <$> (itm ^? itLocation . ilEquipSite . _Just)) ?? eps
chooseFreeSite :: Creature -> [EquipSite] -> Int
chooseFreeSite cr = fromMaybe 0 . findIndex hasnoequipment
where
hasnoequipment ep = isNothing $ cr ^? crEquipment . ix ep
hasnoequipment es = isNothing $ cr ^? crEquipment . ix es
getEquipmentAllocation :: NewInt InvInt -> World -> EquipmentAllocation
getEquipmentAllocation invid w = fromMaybe DoNotMoveEquipment $ do
esite <- you w ^? crInv . ix invid >>= \k -> w ^? cWorld . lWorld . items . ix k >>= equipType-- . itUse . uequipEffect . eeType
i <-
w ^? rbOptions . opSel
<|> Just (chooseEquipPosition (w ^. cWorld . lWorld . items) (you w) (eqSiteToPositions esite))
es <- eqSiteToPositions esite ^? ix i
return $ case you w ^? crInv . ix invid >>= \k -> w ^? cWorld . lWorld . items . ix k . itLocation . ilEquipSite . _Just of
Just epos
| es == epos -> RemoveEquipment{_allocOldPos = epos}
Just epos
| isJust (you w ^? crEquipment . ix es) ->
equipmentDesignation :: NewInt InvInt -> World -> EquipmentAllocation
equipmentDesignation invid w = fromMaybe DoNotMoveEquipment $ do
itid <- you w ^? crInv . ix invid
etype <- w ^? cWorld . lWorld . items . ix itid >>= equipType
let mesite = w ^? cWorld . lWorld . items . ix itid . itLocation . ilEquipSite . _Just
i <- w ^? rbState . opSel
new <- eqTypeToSites etype ^? ix i
return $ case mesite of
Just old | new == old -> RemoveEquipment{_allocOldPos = old}
Just old
| isJust (you w ^? crEquipment . ix new) ->
SwapEquipment
{ _allocOldPos = epos
, _allocNewPos = es
, _allocSwapID = _crEquipment (you w) M.! es
{ _allocOldPos = old
, _allocNewPos = new
, _allocSwapID = _crEquipment (you w) M.! new
}
Just epos ->
MoveEquipment
{ _allocOldPos = epos
, _allocNewPos = es
}
Just old -> MoveEquipment{_allocOldPos = old, _allocNewPos = new}
Nothing
| isJust (you w ^? crEquipment . ix es) ->
| isJust (you w ^? crEquipment . ix new) ->
ReplaceEquipment
{ _allocNewPos = es
, _allocRemoveID = _crEquipment (you w) M.! es
{ _allocNewPos = new
, _allocRemoveID = _crEquipment (you w) M.! new
}
Nothing -> PutOnEquipment{_allocNewPos = es}
Nothing -> PutOnEquipment{_allocNewPos = new}
eqSiteToPositions :: EquipType -> [EquipSite]
eqSiteToPositions es = case es of
eqTypeToSites :: EquipType -> [EquipSite]
eqTypeToSites es = case es of
GoesOnHead -> [OnHead]
GoesOnChest -> [OnChest]
GoesOnBack -> [OnBack]
GoesOnWrist -> [OnLeftWrist, OnRightWrist]
GoesOnLegs -> [OnLegs]
GoesOnLeg -> [OnLeftLeg,OnRightLeg]
src/Dodge/Inventory/SelectionList.hs
+1 -1
View File
@@ -88,7 +88,7 @@ itemExternalValue itm w cr
displayPulse $ cr ^?! crType . avatarPulse . pulseProgress
| Just t <- itm ^? itType . ibtIntroScanType = Just $ introScanValue cr t
| ITEMSCAN <- itm ^. itType
, Just ExamineInventory <- w ^? hud . hudElement . subInventory
, Just ExamineInventory <- w ^? hud . subInventory
= Just (Right "ON")
| BINGATE <- itm ^. itType = do
invid <- itm ^? itLocation . ilInvID
src/Dodge/Inventory/Swap.hs
+6 -6
View File
@@ -24,11 +24,11 @@ swapInvItems ::
World ->
World
swapInvItems f i w = fromMaybe w $ do
ss <- w ^? hud . hudElement . diSections . ix 0 . ssItems
ss <- w ^? hud . diSections . ix 0 . ssItems
k <- f i ss
let updateselection = case w ^? hud . hudElement . diSelection . _Just of
Just (0, j,_) | j == k -> hud . hudElement . diSelection . _Just . _2 .~ i
Just (0, j,_) | j == i -> hud . hudElement . diSelection . _Just . _2 .~ k
let updateselection = case w ^? hud . diSelection . _Just of
Just (Sel 0 j _) | j == k -> hud . diSelection . _Just . slInt .~ i
Just (Sel 0 j _) | j == i -> hud . diSelection . _Just . slInt .~ k
_ -> id
return $
w
@@ -55,11 +55,11 @@ swapInvItems f i w = fromMaybe w $ do
swapAnyExtraSelection :: Int -> Int -> World -> World
swapAnyExtraSelection i k w = fromMaybe w $ do
is <- w ^? hud . hudElement . diSelection . _Just . _3
is <- w ^? hud . diSelection . _Just . slSet
let f = if i `IS.member` is then IS.insert k else id
g = if k `IS.member` is then IS.insert i else id
return $
w & hud . hudElement . diSelection . _Just . _3
w & hud . diSelection . _Just . slSet
%~ (f . g . IS.delete i . IS.delete k)
checkConnection :: SoundOrigin -> SoundID -> Int -> Int -> World -> World
src/Dodge/Item/AimStance.hs
+3 -3
View File
@@ -1,5 +1,5 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Item.AimStance (aimStance,itemBaseStance) where
module Dodge.Item.AimStance (itemAimStance,itemBaseStance) where
import Dodge.Data.Item
import Dodge.Data.ComposedItem
@@ -7,8 +7,8 @@ import Dodge.Data.DoubleTree
import Control.Lens
import Dodge.Data.AimStance
aimStance :: DTree CItem -> AimStance
aimStance dt
itemAimStance :: DTree CItem -> AimStance
itemAimStance dt
| islasweapon = TwoHandFlat
| otherwise = itemBaseStance $ dt ^. dtValue . _1
where
src/Dodge/Item/BackgroundEffect.hs
+1 -1
View File
@@ -20,7 +20,7 @@ import Dodge.Wall.Move
import Geometry.Vector
cancelExamineInventory :: World -> World
cancelExamineInventory = hud . hudElement . subInventory %~ f
cancelExamineInventory = hud . subInventory %~ f
where
f ExamineInventory = NoSubInventory
f x = x
src/Dodge/Item/Draw.hs
+24 -36
View File
@@ -1,52 +1,40 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Item.Draw (
itemSPic,
itemEquipPict,
) where
import qualified Data.IntMap.Strict as IM
import qualified Quaternion as Q
import Dodge.Data.Equipment.Misc
import Dodge.Data.ComposedItem
import Dodge.Data.DoubleTree
import Geometry.Data
module Dodge.Item.Draw (itemEquipPict) where
import Control.Lens
import Dodge.Creature.HandPos
import Dodge.Data.ComposedItem
import Dodge.Data.Creature
import Dodge.Data.DoubleTree
import Dodge.Data.Equipment.Misc
import Dodge.Item.Draw.SPic
import Dodge.Item.HeldOffset
import Geometry.Data
import qualified Quaternion as Q
import ShapePicture
itemEquipPict :: IM.IntMap Item -> Creature -> DTree CItem -> SPic
itemEquipPict m cr itmtree
| --Just i <- itm ^? itLocation . ilInvID
Just esite <- itm ^? itLocation . ilEquipSite . _Just
, Just attachpos <- equipAttachPos <$> itm ^? itType . ibtEquip
= equipPosition esite m cr attachpos (itemSPic itm)
| itm ^? itLocation . ilInvID == cr ^? crManipulation . manObject . imRootSelectedItem
= overPosSP (Q.prePos $ handHandleOrient loc cr) (itemTreeSPic itmtree)
itemEquipPict :: Creature -> DTree CItem -> SPic
itemEquipPict cr itmtree
| Just esite <- itm ^? itLocation . ilEquipSite . _Just
, Just attachpos <- equipAttachPos <$> itm ^? itType . ibtEquip =
equipPosition esite cr attachpos (itemSPic itm)
| itm ^? itLocation . ilInvID == cr ^? crManipulation . manObject . imRootSelectedItem =
overPosSP (Q.prePos $ handHandleOrient loc cr) (itemTreeSPic itmtree)
| otherwise = mempty
where
itm = itmtree ^. dtValue . _1
loc = LocDT TopDT itmtree
equipAttachPos :: EquipItemType -> Point3
equipAttachPos :: EquipItemType -> Point3Q
equipAttachPos = \case
BATTERYPACK -> V3 (-8) 0 10
FUELPACK -> V3 (-9) 0 10
BULLETBELTPACK -> V3 (-9) 0 10
BULLETBELTBRACER -> V3 (-9) 0 10
_ -> 0
BATTERYPACK -> (V3 (-8) 0 10, Q.qID)
FUELPACK -> (V3 (-9) 0 10, Q.qID)
BULLETBELTPACK -> (V3 (-9) 0 10, Q.qID)
BULLETBELTBRACER -> (V3 (-9) 0 10, Q.qID)
_ -> (0, Q.qID)
equipPosition :: EquipSite -> IM.IntMap Item -> Creature -> Point3 -> SPic -> SPic
equipPosition epos m cr p sh = case epos of
OnLeftWrist -> translateToLeftWrist m cr sh
OnRightWrist -> translateToRightWrist m cr sh
OnLegs ->
translateToLeftLeg cr sh
<> translateToRightLeg cr sh-- (mirrorSPxz sh)
OnHead -> translateToHead m cr sh
OnChest -> translateToChest m cr sh
--OnBack -> translateToBack cr p sh
OnBack -> overPosSP (\x -> fst $ backPQ m cr `Q.comp` (p + x,Q.qID)) sh
-- OnSpecial -> sh
equipPosition :: EquipSite -> Creature -> Point3Q -> SPic -> SPic
equipPosition es cr q =
overPosSP
(\x -> fst $ equipSitePQ es cr `Q.comp` q `Q.comp` (x, Q.qID))
src/Dodge/Item/HeldOffset.hs
+3 -2
View File
@@ -34,9 +34,10 @@ handleOrient loc = case loc ^. locDT . dtValue . _1 . itType of
_ -> (V3 (-3) 0 0, Q.qID)
-- note this is relative to the creature
-- the aimstance here should match any aimstance in Aiming
handOrient :: Creature -> AimStance -> Point3Q
handOrient cr = case cr ^. crStance . posture of
Aiming -> \case
Aiming {} -> \case
TwoHandUnder -> (V3 (-3) 0 shoulderHeight, Q.qID)
TwoHandOver -> (V3 0 0 shoulderHeight, Q.qID)
OneHand -> (V3 13 (-2) shoulderHeight, Q.qID)
@@ -60,7 +61,7 @@ locOrient loc cr =
handHandleOrient :: LocationDT CItem -> Creature -> Point3Q
handHandleOrient loc cr =
handOrient cr (aimStance (loc' ^. locDT))
handOrient cr (itemAimStance (loc' ^. locDT))
`Q.comp` handleOrient loc'
where
loc' = locToTop loc
src/Dodge/Item/Info.hs
+1 -1
View File
@@ -257,7 +257,7 @@ equipSiteInfo es = case es of
GoesOnChest -> " on the chest"
GoesOnBack -> " on the back"
GoesOnWrist -> " on a wrist"
GoesOnLegs -> " on both legs"
GoesOnLeg -> " on a leg"
--makeCommaList :: [String] -> String
--makeCommaList [] = ""
src/Dodge/Item/Location/Initialize.hs
-76
View File
@@ -1,76 +0,0 @@
module Dodge.Item.Location.Initialize
( -- initSpecificCrItemLocations
--, initItemLocations
)
where
--import NewInt
--import Dodge.Data.LWorld
--import Control.Lens
--import qualified IntMapHelp as IM
--import Data.Traversable
--initItemLocations :: LWorld -> LWorld
----initItemLocations = initCrsItemLocations . initFlItemsLocations . initTusItemLocations
--initItemLocations = initCrsItemLocations -- . initTusItemLocations
--
--initCrsItemLocations :: LWorld -> LWorld
--initCrsItemLocations w = w' & creatures .~ newcreatures
-- where
-- (w', newcreatures) = mapAccumR initCrItemLocations w (w ^. creatures)
--
----initFlItemsLocations :: LWorld -> LWorld
----initFlItemsLocations w = w' & floorItems .~ newfloorItems
---- where
---- (w', newfloorItems) = mapAccumR initFlItemLocation w (w ^. floorItems)
--
----initTusItemLocations :: LWorld -> LWorld
----initTusItemLocations w = w' & machines .~ newmachines
---- where
---- (w', newmachines) = mapAccumR initTuItemLocation w (w ^. machines)
--
--initSpecificCrItemLocations :: Int -> LWorld -> LWorld
--initSpecificCrItemLocations crid w = w' & creatures . ix crid .~ newcr
-- where
-- (w',newcr) = initCrItemLocations w (w ^?! creatures . ix crid)
--
--initCrItemLocations :: LWorld -> Creature -> (LWorld, Creature)
--initCrItemLocations w cr = (w', cr & crInv .~ newinv)
-- where
-- (w',newinv) = imapAccumR (initCrItemLocation cr) w (_crInv cr)
--
---- does not worry about creature manipulation for now
--initCrItemLocation :: Creature -> Int -> LWorld -> Int -> (LWorld,Item)
--initCrItemLocation cr invid w itid = (w & itemLocations . at locid ?~ loc
-- ,it & itID .~ NInt locid
-- & itLocation .~ loc)
-- where
-- locid = IM.newKey ( w ^. itemLocations)
-- loc = InInv
-- { _ilCrID = _crID cr
-- , _ilInvID = invid
-- , _ilIsRoot = False
-- , _ilIsSelected = False
-- , _ilIsAttached = False
-- , _ilEquipSite = Nothing
-- }
--
--
----initFlItemLocation :: LWorld -> FloorItem -> (LWorld, FloorItem)
----initFlItemLocation w flit = (w & itemLocations . at locid ?~ loc
---- , flit & flIt . itID .~ NInt locid
---- & flIt . itLocation .~ loc
---- )
---- where
---- locid = IM.newKey (w ^. itemLocations )
---- loc = OnFloor (_flItID flit)
--
----initTuItemLocation :: LWorld -> Machine -> (LWorld, Machine)
----initTuItemLocation w mc = case mc ^? mcType . _McTurret . tuWeapon of
---- Nothing -> (w, mc)
---- Just _ ->
---- let locid = IM.newKey ( w ^. itemLocations)
---- loc = OnTurret (_mcID mc)
---- in ( w & itemLocations . at locid ?~ loc
---- , mc & mcType . _McTurret . tuWeapon . itID .~ NInt locid
---- & mcType . _McTurret . tuWeapon . itLocation .~ loc
---- )
src/Dodge/ListDisplayParams.hs
+7 -7
View File
@@ -1,9 +1,9 @@
module Dodge.ListDisplayParams (
invDP,
invCursorParams,
secondColumnParams,
secondColumnLDP,
subInvX,
menuDisplayParams,
menuLDP,
) where
import Control.Lens
@@ -34,14 +34,14 @@ invDP =
& ldpPos . spPixelOff .~ V2 6 0
invCursorParams :: World -> CursorDisplay
invCursorParams w = BoundaryCursor $ case w ^? hud . hudElement . subInventory of
invCursorParams w = BoundaryCursor $ case w ^? hud . subInventory of
-- Just ExamineInventory{} -> [North, South, East, West]
Just CombineInventory{} -> []
_ | ButtonRight `M.member` _mouseButtons (_input w) -> [North, South, East, West]
_ -> [North, South, West]
secondColumnParams :: ListDisplayParams
secondColumnParams =
secondColumnLDP :: ListDisplayParams
secondColumnLDP =
defaultListDisplayParams
& ldpPos . spPixelOff .~ V2 subInvX (-81)
@@ -51,8 +51,8 @@ subInvX = 10 * fromIntegral topInvW + 70
topInvW :: Int
topInvW = 15
menuDisplayParams :: ListDisplayParams
menuDisplayParams =
menuLDP :: ListDisplayParams
menuLDP =
defaultListDisplayParams
& ldpPos . spPixelOff .~ V2 11 (-70)
& ldpScale .~ 2
src/Dodge/Machine/Update.hs
+29 -17
View File
@@ -1,9 +1,7 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Machine.Update (
updateMachine,
) where
import Dodge.Terminal.Color
module Dodge.Machine.Update (updateMachine) where
import Control.Monad
import Data.List (partition)
import Data.Maybe
@@ -11,9 +9,12 @@ import Dodge.Base.Collide
import Dodge.Base.You
import Dodge.Data.World
import Dodge.HeldUse
import Dodge.Item.Display
import Dodge.Machine.Destroy
import Dodge.Movement.Turn
import Dodge.SoundLogic
import Dodge.Terminal
import Dodge.Terminal.Color
import Geometry
import LensHelp
@@ -40,6 +41,7 @@ terminalScreenGlow mc w = fromMaybe w $ do
return $
w & cWorld . lWorld . lights
.:~ LSParam (_mcPos mc `v2z` 20) 30 (V3 x y z)
-- w & cWorld . lWorld . tempLightSources
-- .:~ TLS
-- { _tlsParam = LSParam (_mcPos mc `v2z` 20) 30 (V3 x y z)
@@ -140,21 +142,32 @@ mcProximitySensorUpdate mc w = case ( _proxStatus sens
& cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . sensToggle .~ True
& playsound dedaS
& cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ IsClose
& cWorld . lWorld . terminals . ix (mc ^?! mcMounts . ix OTTerminal) . tmFutureLines .:~ makeTermLine "SENSOR SUCCESS!"
(NotClose, _, False, True) ->
w & playsound dedumS
& cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ IsClose
(_, _, _, False) -> w & cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ NotClose
& cWorld . lWorld . terminals . ix (mc ^?! mcMounts . ix OTTerminal) . tmFutureLines
.:~ makeTermLine ("SENSOR FAIL: REQUIRES " ++ sensorReqToString (mc ^?! mcType . _McSensor . proxRequirement))
(_, _, _, False) ->
w & cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ NotClose
_ -> w
where
playsound sid = soundContinue (MachineAltSound (_mcID mc)) (_mcPos mc) sid Nothing
ycr = you w
sens = mc ^?! mcType . _McSensor
sensorReqToString :: ProximityRequirement -> String
sensorReqToString = \case
RequireHealth x -> "HEALTH ABOVE " ++ show x
RequireEquipment x -> itemBaseName x
mcProxTest :: Machine -> World -> Bool
mcProxTest mc w = case mc ^? mcType . _McSensor . proxRequirement of
Just (RequireHealth x) -> _crHP cr >= x
Just (RequireEquipment ct) -> any (\itm -> _itType itm == ct)
(fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ _crInv cr)
Just (RequireEquipment ct) ->
any
(\itm -> _itType itm == ct)
((\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr)
_ -> False
where
cr = you w
@@ -179,24 +192,23 @@ senseDamage threshold dt mc =
sensorTypeDamages :: SensorType -> Damage -> Bool
sensorTypeDamages = \case
LaserSensor -> \case
LaserSensor -> \case
Lasering{} -> True
_ -> False
ElectricSensor -> \case
Electrical {} -> True
Electrical{} -> True
_ -> False
ThermalSensor -> \case
Flaming {} -> True
Sparking {} -> True
Explosive {} -> True
Flaming{} -> True
Sparking{} -> True
Explosive{} -> True
_ -> False
PhysicalSensor -> \case
Piercing {} -> True
Blunt {} -> True
Crushing {} -> True
Explosive {} -> True
Piercing{} -> True
Blunt{} -> True
Crushing{} -> True
Explosive{} -> True
_ -> False
--damageUsing :: DamageType -> Damage -> Either Int Int
--damageUsing dt dm
src/Dodge/Menu/Option.hs
+1 -1
View File
@@ -24,7 +24,7 @@ initializeOptionMenu title ops pmo u =
, _scPositionedMenuOption = pmo
, _scOptionFlag = NormalOptions
, _scSelectionList = optionsToSelections 10 u ops pmo
, _scAvailableLines = getAvailableListLines menuDisplayParams (u ^. uvConfig)
, _scAvailableLines = getAvailableListLines menuLDP (u ^. uvConfig)
, _scDisplayTime = 0
}
src/Dodge/Picture/SizeInvariant.hs
+2 -2
View File
@@ -34,7 +34,7 @@ import Picture
-- Int ->
-- Picture ->
-- Point2 ->
-- Configuration ->
-- Config ->
-- Camera ->
-- Picture
--fixedSizePicClamp xbord ybord pic p cfig w =
@@ -61,7 +61,7 @@ fixedSizePicClampArrow ::
Float ->
Picture ->
Point2 ->
Configuration ->
Config ->
World ->
Picture
fixedSizePicClampArrow xbord ybord pic p cfig w =
src/Dodge/Placement/Instance/Analyser.hs
+3 -6
View File
@@ -4,7 +4,7 @@ import Color
import Dodge.Data.GenWorld
import Dodge.Default
import Dodge.Placement.Instance
import Dodge.Terminal
--import Dodge.Terminal
import LensHelp
analyser :: ProximityRequirement -> PlacementSpot -> PlacementSpot -> Placement
@@ -13,14 +13,11 @@ analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
plSpot .~ psmc $
putTerminal (dark magenta)
(themachine & mcMounts . at OTTrigger .~ _plMID tp)
tparams -- (linksensortotrigger tp)
tparams
where
tparams = textTerminal & tmCommands .:~ TCSensorInfo
-- linksensortotrigger tp _ mc
-- = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
tparams = defaultTerminal & tmStatus .~ TerminalLineRead
themachine =
defaultMachine & mcColor .~ aquamarine
-- & mcUpdate .~ mcProximitySensorUpdate
& mcType .~ McTerminal
& mcHP .~ 100
& mcType .~ McSensor (defaultProximitySensor{_proxRequirement = proxreq})
src/Dodge/Placement/Instance/Terminal.hs
+7 -2
View File
@@ -5,13 +5,13 @@ module Dodge.Placement.Instance.Terminal (
terminalColor,
) where
import Dodge.WorldEffect
import Color
import Data.Maybe
import Dodge.Data.GenWorld
import Dodge.Default
import Dodge.LevelGen.PlacementHelper
import Dodge.SoundLogic
import Dodge.WorldEffect
import Geometry
import LensHelp
@@ -20,7 +20,11 @@ putTerminalImediateAccess = putTerminalFull f
where
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ accessTerminal (tmpl ^?! plMID . _Just)
putTerminalFull ::(Placement -> Placement -> Placement -> Maybe Placement) -> Color -> Machine -> Terminal ->
putTerminalFull ::
(Placement -> Placement -> Placement -> Maybe Placement) ->
Color ->
Machine ->
Terminal ->
Placement
putTerminalFull f col mc tm =
ps0PushPS (PutTerminal (tm & tmExternalColor .~ col)) $
@@ -31,6 +35,7 @@ putTerminalFull f col mc tm =
( PutMachine
(reverse $ square 10)
( mc & mcMounts . at OTButton ?~ fromJust (_plMID btpl)
& mcMounts . at OTTerminal .~ _plMID tmpl
& mcCloseSound ?~ fridgeHumS
)
defaultSensorWall
src/Dodge/Placement/PlaceSpot.hs
+30 -22
View File
@@ -1,12 +1,12 @@
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{- | deals with placement of objects within the world
after they have had their coordinates set by the layout
-}
module Dodge.Placement.PlaceSpot (placeSpot) where
import NewInt
import Color
import LensHelp
import Control.Monad.State
import Data.Bifunctor
import Data.Foldable
@@ -21,6 +21,8 @@ import Dodge.Placement.Shift
import Dodge.ShiftPoint
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import NewInt
import System.Random
-- when placing a placement, we update the world and the room and assign an id
@@ -109,17 +111,21 @@ placeSpotID' ps pt w = case pt of
PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w
PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
PutFlIt itm -> let i = IM.newKey (w ^. cWorld . lWorld . items)
in (i, w
& cWorld . lWorld . floorItems . at i ?~ createFlIt p rot
& cWorld . lWorld . items . at i ?~ (itm & itID .~ NInt i
& itLocation .~ OnFloor)
PutFlIt itm ->
let i = IM.newKey (w ^. cWorld . lWorld . items)
in ( i
, w
& cWorld . lWorld . floorItems . at i ?~ FlIt p rot
& cWorld . lWorld . items . at i
?~ ( itm & itID .~ NInt i
& itLocation .~ OnFloor
)
)
-- plNewUpID
-- (cWorld . lWorld . floorItems . unNIntMap)
-- (flItID . unNInt)
-- (createFlIt p rot itm)
-- w
-- plNewUpID
-- (cWorld . lWorld . floorItems . unNIntMap)
-- (flItID . unNInt)
-- (createFlIt p rot itm)
-- w
PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID (mvFS p rot fs) w
PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
@@ -181,10 +187,6 @@ mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
mvButton :: Point2 -> Float -> Button -> Button
mvButton p a = (btRot +~ a) . (btPos %~ ((p +.+) . rotateV a))
{- Creates a floor item at a given point.-}
createFlIt :: Point2 -> Float -> FloorItem
createFlIt p rot = FlIt{_flItPos = p, _flItRot = rot}
mvPP :: Point2 -> Float -> PressPlate -> PressPlate
mvPP p rot pp = pp{_ppPos = p, _ppRot = rot}
@@ -194,8 +196,9 @@ mvCr p rot cr = cr{_crPos = p, _crOldPos = p, _crDir = rot}
mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
plMachine :: [Point2] -> Machine -> Wall -> Maybe Item -> Point2 -> Float -> World -> (Int, World)
plMachine wallpoly mc wl mitm = case mitm of
plMachine ::
[Point2] -> Machine -> Wall -> Maybe Item -> Point2 -> Float -> World -> (Int, World)
plMachine wallpoly mc wl = \case
Nothing -> plMachine' wallpoly mc wl
Just itm -> plTurret wallpoly mc wl itm
@@ -207,15 +210,20 @@ plTurret wallpoly mc wl itm p rot gw =
& cWorld . lWorld . items . at itid ?~ itm'
)
where
itm' = itm & itID .~ NInt itid
& itLocation .~ OnTurret mcid
itm' =
itm & itID .~ NInt itid
& itLocation .~ OnTurret mcid
itid = IM.newKey $ gw ^. cWorld . lWorld . items
col = _mcColor mc
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
& mcType . mctTurret . tuWeapon .~ itid)
addMc =
IM.insert
mcid
( mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
& mcType . mctTurret . tuWeapon .~ itid
)
plMachine' :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int, World)
plMachine' wallpoly mc wl p rot gw =
src/Dodge/Projectile/Create.hs
-2
View File
@@ -43,8 +43,6 @@ createShell (p,q) mdetonator mscreen stab pjtype payload muz cr w =
, _pjPayload = payload
, _pjTimer = lifespan
, _pjBarrelSpin = bs
-- , _pjUpdates =
-- anyspin
, _pjType = pjtype
, _pjDetonatorID = mdetonator
, _pjScreenID = mscreen
src/Dodge/Projectile/Update.hs
-2
View File
@@ -209,8 +209,6 @@ doThrust pj smoke w =
(sparkD, _) = randomR (-0.2, 0.2) $ _randGen w
r1 = randInCirc 10 & evalState $ _randGen w
-- there doesn't seem to be a more sensible way to filter the first occurence of
-- a list than deleteBy
doBarrelSpin :: Int -> Float -> Projectile -> World -> World
doBarrelSpin cid i pj w =
w & cWorld . lWorld . projectiles . ix pjid . pjSpin .~ newSpin
src/Dodge/Render.hs
+2 -2
View File
@@ -432,10 +432,10 @@ doDrawing' win pdata u = do
renderLayer FixedCoordLayer shadV pokeCounts
SDL.glSwapWindow win
getDistortions :: Configuration -> World -> [Distortion]
getDistortions :: Config -> World -> [Distortion]
getDistortions cfig w
| cfig ^. graphics_distortions = w ^. cWorld . lWorld . distortions
| otherwise = []
setViewport :: (Configuration -> ResFactor) -> Configuration -> IO ()
setViewport :: (Config -> ResFactor) -> Config -> IO ()
setViewport f = uncurry (glViewport 0 0) . getWindowSize f
src/Dodge/Render/HUD.hs
+56 -55
View File
@@ -45,27 +45,27 @@ import NewInt
import Picture
import SDL (MouseButton (..))
drawHUD :: Configuration -> World -> Picture
drawHUD cfig w = case w ^. hud . hudElement of
drawHUD :: Config -> World -> Picture
drawHUD cfig w = case w ^. hud of
-- DisplayCarte -> drawCarte cfig w
DisplayInventory{_diSections = sections, _subInventory = subinv} ->
HUD {_diSections = sections, _subInventory = subinv} ->
drawInventory sections w cfig
<> drawSubInventory subinv cfig w
drawInventory :: IM.IntMap (SelectionSection ()) -> World -> Configuration -> Picture
drawInventory :: IM.IntMap (SelectionSection ()) -> World -> Config -> Picture
drawInventory sss w cfig =
drawSelectionSections sss invDP cfig
<> drawSSCursor sss invDP curs cfig (f $ w ^? hud . hudElement . diSelection . _Just)
<> drawRootCursor w sss (f $ w ^? hud . hudElement . diSelection . _Just) invDP cfig
<> drawSSCursor sss invDP curs cfig (f $ w ^? hud . diSelection . _Just)
<> drawRootCursor w sss (f $ w ^? hud . diSelection . _Just) invDP cfig
<> itemconnections
<> drawMouseOver cfig w
where
f = fmap (\(x, y, _) -> (x, y))
f = fmap (\(Sel x y _) -> (x, y))
curs = invCursorParams w
itemconnections = fromMaybe mempty $ do
inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
let inv = fmap (\k -> w ^?! cWorld . lWorld . items . ix k) inv'
case w ^? hud . hudElement . diInvFilter . _Just of
case w ^? hud . diInvFilter . _Just of
Just (_ : _) -> Nothing
_ -> return . drawItemConnections sss cfig $ invAdj inv
@@ -74,7 +74,7 @@ drawRootCursor ::
IM.IntMap (SelectionSection ()) ->
Maybe (Int, Int) ->
ListDisplayParams ->
Configuration ->
Config ->
Picture
drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0
@@ -102,7 +102,7 @@ getRootItemBounds i inv = do
y <- locDTLeftmost root ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
return (x, y)
drawMouseOver :: Configuration -> World -> Picture
drawMouseOver :: Config -> World -> Picture
drawMouseOver cfig w =
concat
(invsel <|> combinvsel <|> drawDragSelecting cfig w)
@@ -112,7 +112,7 @@ drawMouseOver cfig w =
(j, i) <-
w ^? input . mouseContext . mcoInvSelect
<|> w ^? input . mouseContext . mcoInvFilt
sss <- w ^? hud . hudElement . diSections
sss <- w ^? hud . diSections
return . translateScreenPos cfig (invDP ^. ldpPos)
. color (withAlpha 0.1 white)
-- . color white
@@ -123,40 +123,40 @@ drawMouseOver cfig w =
(j, i) <-
(w ^? input . mouseContext . mcoCombSelect)
<|> (w ^? input . mouseContext . mcoCombCombine)
sss <- w ^? hud . hudElement . subInventory . ciSections
let idp = secondColumnParams
sss <- w ^? hud . subInventory . ciSections
let idp = secondColumnLDP
return . translateScreenPos cfig (idp ^. ldpPos)
. color (withAlpha 0.2 white)
$ selSecDrawCursorAt idp curs sss (j, i)
drawDragSelected :: Configuration -> World -> Maybe Picture
drawDragSelected :: Config -> World -> Maybe Picture
drawDragSelected cfig w = do
ys <- w ^? hud . hudElement . diSelection . _Just . _3
ys <- w ^? hud . diSelection . _Just . slSet
guard $
not (IS.null ys)
&& ( case w ^? hud . hudElement . subInventory of
&& ( case w ^? hud . subInventory of
Just NoSubInventory -> True
_ -> False
)
(i, _, _) <- w ^? hud . hudElement . diSelection . _Just
sss <- w ^? hud . hudElement . diSections
Sel i _ _ <- w ^? hud . diSelection . _Just
sss <- w ^? hud . diSections
let f x = (selSecDrawCursorAt invDP BackdropCursor sss (i, x) <>)
return . translateScreenPos cfig (invDP ^. ldpPos)
. color (withAlpha 0.2 white)
. IS.foldr f mempty
$ ys
drawDragSelecting :: Configuration -> World -> Maybe Picture
drawDragSelecting :: Config -> World -> Maybe Picture
drawDragSelecting cfig w = do
OverInvDragSelect (Just (i, j)) (Just b) <- w ^? input . mouseContext
sss <- w ^? hud . hudElement . diSections
sss <- w ^? hud . diSections
let f x = selSecDrawCursorAt invDP BackdropCursor sss (i, x)
return . translateScreenPos cfig (invDP ^. ldpPos)
. color (withAlpha 0.2 white)
. foldMap f
$ [min j b .. max j b]
drawSubInventory :: SubInventory -> Configuration -> World -> Picture
drawSubInventory :: SubInventory -> Config -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
-- LockedInventory -> mempty -- topInvCursor col cursPos cfig w
NoSubInventory{} -> drawRBOptions cfig w
@@ -176,26 +176,26 @@ drawMapperInventory itid w = fold $ do
f = worldPosToScreen (w ^. wCam)
drawCombineInventory ::
Configuration ->
Config ->
IM.IntMap (SelectionSection CombinableItem) ->
World ->
Picture
drawCombineInventory cfig sss w =
invHead cfig "COMBINE"
<> drawSelectionSections sss secondColumnParams cfig
<> drawSSCursor sss secondColumnParams curs cfig msel
<> drawSelectionSections sss secondColumnLDP cfig
<> drawSSCursor sss secondColumnLDP curs cfig msel
<> combineInventoryExtra sss msel cfig w
where
curs = BoundaryCursor [North, South, West]
msel =
fmap (\(x, y, _) -> (x, y)) $
w ^? hud . hudElement . subInventory . ciSelection . _Just
fmap (\(Sel x y _) -> (x, y)) $
w ^? hud . subInventory . ciSelection . _Just
drawExamineInventory :: Configuration -> World -> Picture
drawExamineInventory :: Config -> World -> Picture
drawExamineInventory cfig w =
invHead cfig "EXAMINE"
<> drawSelectionList
secondColumnParams
secondColumnLDP
cfig
( map
f
@@ -244,17 +244,18 @@ yourAugmentedItem f x g w = case you w ^? crManipulation . manObject of
return . g $ Right but
_ -> x
drawRBOptions :: Configuration -> World -> Picture
drawRBOptions :: Config -> World -> Picture
drawRBOptions cfig w = fold $ do
guard $ ButtonRight `M.member` _mouseButtons (_input w)
invid <- you w ^? crManipulation . manObject . imSelectedItem
itid <- you w ^? crInv . ix invid
eslist <-
fmap eqSiteToPositions $
you w ^? crInv . ix invid >>= \k -> w ^? cWorld . lWorld . items . ix k >>= equipType -- . itUse . uequipEffect . eeType
i <- w ^? rbOptions . opSel
let ae = getEquipmentAllocation invid w
sss <- w ^? hud . hudElement . diSections
(i', j, _) <- w ^? hud . hudElement . diSelection . _Just
fmap eqTypeToSites $
w ^? cWorld . lWorld . items . ix itid >>= equipType
i <- w ^? rbState . opSel
let ae = equipmentDesignation invid w
sss <- w ^? hud . diSections
Sel i' j _ <- w ^? hud . diSelection . _Just
curpos <- selSecYint i' j sss
let ytext = drawListElement 0 1 0 curpos . text
midstr = equipAllocString ae
@@ -298,9 +299,8 @@ drawRBOptions cfig w = fold $ do
maybebottomborder a b curpos
| a == b - 1 = listCursorChooseBorderScale 0 1 (bc South) curpos 0 white 7 1
| otherwise = mempty
otheritem j = fromMaybe "" $ do
itid <- you w ^? crInv . ix j
itype <- w ^? cWorld . lWorld . items . ix itid . itType
otheritem (NInt j) = fromMaybe "" $ do
itype <- w ^? cWorld . lWorld . items . ix j . itType
return $ itemBaseName itype
equipAllocString :: EquipmentAllocation -> String
@@ -314,7 +314,7 @@ equipAllocString = \case
drawItemConnections ::
IM.IntMap (SelectionSection ()) ->
Configuration ->
Config ->
IM.IntMap (Maybe (Int, Int), [Int], [Int]) ->
Picture
drawItemConnections sss cfig =
@@ -324,7 +324,7 @@ drawItemConnections sss cfig =
drawItemChildrenConnect ::
IM.IntMap (SelectionSection ()) ->
Configuration ->
Config ->
Int ->
[Int] ->
Picture
@@ -338,7 +338,7 @@ drawItemChildrenConnect sss cfig i is = fromMaybe mempty $ do
combineInventoryExtra ::
IM.IntMap (SelectionSection CombinableItem) ->
Maybe (Int, Int) ->
Configuration ->
Config ->
World ->
Picture
combineInventoryExtra sss msel cfig w = fold $ do
@@ -349,7 +349,7 @@ combineInventoryExtra sss msel cfig w = fold $ do
return (lnkMidPosInvSelsCol cfig w j col lnks) <> foldMap invcursor lnks
where
invcursor i = do
sss' <- w ^? hud . hudElement . diSections
sss' <- w ^? hud . diSections
return $
translateScreenPos cfig (invDP ^. ldpPos) $
selSecDrawCursor
@@ -358,13 +358,13 @@ combineInventoryExtra sss msel cfig w = fold $ do
sss'
(Just (0, i))
drawTerminalDisplay :: Configuration -> Terminal -> Picture
drawTerminalDisplay :: Config -> Terminal -> Picture
drawTerminalDisplay cfig tm =
invHead cfig ("T-" ++ show tid)
<> drawSelectionList secondColumnParams cfig f
<> drawSelectionList secondColumnLDP cfig f
<> color
(withAlpha 0.5 green) -- consider integrating termScreenColor somehow
(drawSelectionListBackground secondColumnParams cfig tsize)
(drawSelectionListBackground secondColumnLDP cfig tsize)
<> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig)
where
tid = tm ^. tmID
@@ -380,6 +380,7 @@ drawTerminalDisplay cfig tm =
TerminalOff -> id
TerminalDeactivated -> id
TerminalLineRead -> id
TerminalWaiting -> (++ [("...",white)])
TerminalTextInput s ->
(++ [(getPromptTM ++ s ++ [cFilledRect], white)])
TerminalPressTo s ->
@@ -387,18 +388,18 @@ drawTerminalDisplay cfig tm =
-- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w
lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
lnkMidPosInvSelsCol :: Config -> World -> Int -> Color -> [Int] -> Picture
lnkMidPosInvSelsCol cfig w i col = fromMaybe mempty . foldMap f
where
f j = do
sss <- w ^? hud . hudElement . diSections
combinesss <- w ^? hud . hudElement . subInventory . ciSections
sss <- w ^? hud . diSections
combinesss <- w ^? hud . subInventory . ciSections
lp <- selNumPos cfig invDP sss 0 j
rp <- selNumPos cfig secondColumnParams combinesss 0 i
rp <- selNumPos cfig secondColumnLDP combinesss 0 i
invcol <- selSecSelCol 0 j sss
return $ zConnectColMidX (rp - V2 5 0) (lp + V2 155 0) (rp ^. _1 - 20) col col col invcol
invHead :: Configuration -> String -> Picture
invHead :: Config -> String -> Picture
invHead cfig =
translateScreenPos cfig (fromTopLeft (V2 subInvX 80))
. dShadCol white
@@ -408,7 +409,7 @@ invHead cfig =
--locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w
--locTexts = map fst locs
--displayListEndCoords :: Configuration -> [String] -> [Point2]
--displayListEndCoords :: Config -> [String] -> [Point2]
--displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..]
-- where
-- f :: Int -> Point2
@@ -416,7 +417,7 @@ invHead cfig =
-- h :: String -> Point2 -> Point2
-- h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y
--closeObjectTexts :: Configuration -> World -> Picture
--closeObjectTexts :: Config -> World -> Picture
--closeObjectTexts cfig w = pictures $
-- renderListAt pushout (negate 20 * fromIntegral invPos) cfig (map colAndText $ _closeObjects w)
-- : maybeToList maybeLine
@@ -448,9 +449,9 @@ invHead cfig =
-- would be nice to add parameter to orient this with NSEW, cf cursor
selNumPos ::
Configuration ->
Config ->
ListDisplayParams ->
IM.IntMap (SelectionSection a) ->
IMSS a ->
Int ->
Int ->
Maybe Point2
@@ -472,7 +473,7 @@ selNumPos = selNumPosCardinal West8
-- need to be able to determine a selection item's width for this
selNumPosCardinal ::
CardinalEightPoint ->
Configuration ->
Config ->
ListDisplayParams ->
IM.IntMap (SelectionSection a) ->
Int ->
src/Dodge/Render/HUD/Carte.hs
+4 -4
View File
@@ -11,7 +11,7 @@ module Dodge.Render.HUD.Carte (
--import qualified IntMapHelp as IM
--import Picture
--
----drawCarte :: Configuration -> World -> Picture
----drawCarte :: Config -> World -> Picture
----drawCarte cfig w =
---- fold $
---- toTopLeft cfig (renderListAt 0 0 locs) :
@@ -38,7 +38,7 @@ module Dodge.Render.HUD.Carte (
-- (x, y) = _wlLine wl
-- c = _wlColor wl
--
----mapWall :: Configuration -> HUD -> Wall -> Maybe Picture
----mapWall :: Config -> HUD -> Wall -> Maybe Picture
----mapWall cfig thehud wl
---- | _wlSeen wl = Just . color c . polygon $ map (cartePosToScreen cfig thehud) [x, x +.+ n2, y +.+ n2, y]
---- | otherwise = Nothing
@@ -48,7 +48,7 @@ module Dodge.Render.HUD.Carte (
---- (x, y) = _wlLine wl
---- c = _wlColor wl
--
--mainListCursor :: Color -> Int -> Configuration -> Picture
--mainListCursor :: Color -> Int -> Config -> Picture
--mainListCursor c = openCursorAt 120 c 5 0
--
--openCursorAt ::
@@ -61,7 +61,7 @@ module Dodge.Render.HUD.Carte (
-- Float ->
-- -- | y offset (discrete)
-- Int ->
-- Configuration ->
-- Config ->
-- Picture
--openCursorAt wth col xoff yoff yint w =
-- translate (xoff - halfWidth w) (halfHeight w - (20 * fromIntegral yint + yoff) - 20) $
src/Dodge/Render/InfoBox.hs
+2 -2
View File
@@ -17,7 +17,7 @@ import Picture
renderInfoListAt ::
Float ->
Float ->
Configuration ->
Config ->
Camera ->
(Point2, [String]) ->
Picture
@@ -41,7 +41,7 @@ renderInfoListAt x y cfig cam (p, ss) =
hw = halfWidth cfig
hh = halfHeight cfig
renderInfoListsAt :: Float -> Float -> Configuration -> Camera -> [(Point2, [String])] -> Picture
renderInfoListsAt :: Float -> Float -> Config -> Camera -> [(Point2, [String])] -> Picture
renderInfoListsAt x y cfig w =
fst . foldr f (mempty, 0)
where
src/Dodge/Render/Lights.hs
+1 -1
View File
@@ -11,7 +11,7 @@ import Geometry
import qualified IntMapHelp as IM
import Control.Lens
lightsToRender :: Configuration -> Camera -> LWorld -> [(Point3, Float, Point3)]
lightsToRender :: Config -> Camera -> LWorld -> [(Point3, Float, Point3)]
{-# INLINE lightsToRender #-}
lightsToRender cfig campos w = take (fromEnum $ cfig ^. graphics_num_shadow_casters) $
sortOn (\(_,x,_) -> negate x) $
src/Dodge/Render/List.hs
+6 -6
View File
@@ -32,7 +32,7 @@ import LensHelp
import ListHelp
import Picture
drawSelectionList :: ListDisplayParams -> Configuration -> [SelectionItem a] -> Picture
drawSelectionList :: ListDisplayParams -> Config -> [SelectionItem a] -> Picture
drawSelectionList ldps cfig sl =
translateScreenPos cfig (ldps ^. ldpPos) $
drawListYgapScaleYoff
@@ -41,7 +41,7 @@ drawSelectionList ldps cfig sl =
0
(makeSelectionListPictures sl)
drawTitleBackground :: Configuration -> Picture
drawTitleBackground :: Config -> Picture
drawTitleBackground cfig =
translateScreenPos cfig (fromTopLeft (V2 (subInvX - 5) 75))
. polygon
@@ -50,7 +50,7 @@ drawTitleBackground cfig =
drawSelectionListBackground ::
ListDisplayParams ->
Configuration ->
Config ->
Int -> -- list length
Picture
drawSelectionListBackground ldp cfig l =
@@ -164,7 +164,7 @@ chooseCursorBorders w h = \case
toLine South = [V2 w h', V2 0 h']
toLine West = [V2 0 h', V2 0 0]
--fillScreenText :: Configuration -> String -> Picture
--fillScreenText :: Config -> String -> Picture
--fillScreenText cfig str =
-- scale wscale hscale
-- . centerText
@@ -175,7 +175,7 @@ chooseCursorBorders w h = \case
-- hw = halfWidth cfig
-- hh = halfHeight cfig
--fillWidthText :: Configuration -> String -> Picture
--fillWidthText :: Config -> String -> Picture
--fillWidthText cfig str =
-- scale thescale thescale
-- . centerText
@@ -216,5 +216,5 @@ dShadCol :: Color -> Picture -> Picture
{-# INLINE dShadCol #-}
dShadCol c p = color black (translate 1.2 (-1.2) p) <> color c p
toTopLeft :: Configuration -> Picture -> Picture
toTopLeft :: Config -> Picture -> Picture
toTopLeft cfig = translate (- halfWidth cfig) (halfHeight cfig)
src/Dodge/Render/MenuScreen.hs
+9 -9
View File
@@ -13,14 +13,14 @@ import Dodge.Render.List
import Dodge.ScreenPos
import Picture
drawMenuScreen :: Configuration -> Maybe Int -> ScreenLayer -> Picture
drawMenuScreen :: Config -> Maybe Int -> ScreenLayer -> Picture
drawMenuScreen cfig spos screen = case screen of
OptionScreen{_scTitle = titf, _scSelectionList = slist} ->
drawOptions cfig titf spos slist
InputScreen inputstr help -> drawInputMenu cfig ('>' : inputstr) help
drawInputMenu ::
Configuration ->
Config ->
-- | Title
String ->
-- | Help Text
@@ -33,26 +33,26 @@ drawInputMenu cfig title footer =
, drawFooterText cfig red footer
]
drawOptions :: Configuration -> String -> Maybe Int -> [SelectionItem a] -> Picture
drawOptions :: Config -> String -> Maybe Int -> [SelectionItem a] -> Picture
drawOptions cfig title msel sl =
darkenBackground cfig
<> drawTitle cfig title
<> drawSelectionList menuDisplayParams cfig sl
<> drawSelectionList menuLDP cfig sl
<> translateScreenPos
cfig
(menuDisplayParams ^. ldpPos)
(menuLDP ^. ldpPos)
( drawCursorAt
msel
sl
menuDisplayParams
menuLDP
50
(BoundaryCursor [North, South])
)
darkenBackground :: Configuration -> Picture
darkenBackground :: Config -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
drawTitle :: Configuration -> String -> Picture
drawTitle :: Config -> String -> Picture
drawTitle cfig = translate (- hw) (hh -80) . scale 0.4 0.4 . text
where
hh = halfHeight cfig
@@ -69,7 +69,7 @@ placeString ::
Picture
placeString x y sc = color white . translate x y . scale sc sc . text
drawFooterText :: Configuration -> Color -> String -> Picture
drawFooterText :: Config -> Color -> String -> Picture
drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
where
hh = halfHeight cfig
src/Dodge/Render/Picture.hs
+12 -12
View File
@@ -35,7 +35,7 @@ fixedCoordPictures u =
. take 50
. drop (u ^. uvDebugMessageOffset)
. map text
$ foldMap (`_debugMessage` u) (_uvDebug u) -- other debug pics in extraPics
$ foldMap _debugMessage (_uvDebug u) -- other debug pics in extraPics
)
where
cfig = _uvConfig u
@@ -61,7 +61,7 @@ fpsText x = color col . text $ "ms/frame " ++ show x
| x < 50 = orange
| otherwise = red
drawMenuOrHUD :: Configuration -> Universe -> Picture
drawMenuOrHUD :: Config -> Universe -> Picture
drawMenuOrHUD cfig u = case u ^. uvScreenLayers of
[] -> drawHUD (u ^. uvConfig) (u ^. uvWorld)
(x : _) -> drawMenuScreen cfig (u ^? uvWorld . input . mouseContext . mcoMenuClick) x
@@ -91,15 +91,15 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
MouseMenuClick{} -> drawMenuClick 5
MouseMenuCursor -> drawMenuCursor 5
MouseInGame -> drawPlus 5
OverInvDrag 0 (Just (3, _)) _ _ -> drawDragDrop 5
OverInvDrag 0 Nothing _ _ -> drawDragDrop 5
OverInvDrag 0 (Just (0, _)) _ _ -> drawDrag 5
OverInvDrag 0 _ _ _ -> drawEmptySet 5
OverInvDrag 3 (Just (3, _)) _ _ -> drawDrag 5
OverInvDrag 3 (Just (0, _)) _ _ -> drawDragPickup 5
OverInvDrag 3 (Just (1, _)) _ _ -> drawDragPickup 5
OverInvDrag 3 Nothing _ _ -> drawDragPickup 5
OverInvDrag 3 _ _ _ -> drawEmptySet 5
OverInvDrag 0 (Just (3, _)) -> drawDragDrop 5
OverInvDrag 0 Nothing -> drawDragDrop 5
OverInvDrag 0 (Just (0, _)) -> drawDrag 5
OverInvDrag 0 _ -> drawEmptySet 5
OverInvDrag 3 (Just (3, _)) -> drawDrag 5
OverInvDrag 3 (Just (0, _)) -> drawDragPickup 5
OverInvDrag 3 (Just (1, _)) -> drawDragPickup 5
OverInvDrag 3 Nothing -> drawDragPickup 5
OverInvDrag 3 _ -> drawEmptySet 5
OverInvDrag{} -> drawEmptySet 5
OverInvDragSelect{} -> drawDragSelect 5
OverInvSelect (-1, _) | selsec == Just (-1) -> drawJumpDown 5
@@ -115,7 +115,7 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
MouseGameRotate -> rotate a (drawVerticalDoubleArrow 5)
where
w = u ^. uvWorld
selsec = u ^? uvWorld . hud . hudElement . diSelection . _Just . _1
selsec = u ^? uvWorld . hud . diSelection . _Just . slSec
a = fromMaybe 0 $ do
cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
return . toClosestMultiple (pi / 32) $
src/Dodge/Render/ShapePicture.hs
+8 -7
View File
@@ -2,6 +2,7 @@ module Dodge.Render.ShapePicture (
worldSPic,
) where
import Dodge.Item.Draw.SPic
import Control.Lens
import Data.Foldable
import Data.Strict.Tuple
@@ -18,7 +19,7 @@ import Shape
import ShapePicture
import Linear.V3
worldSPic :: Configuration -> Universe -> SPic
worldSPic :: Config -> Universe -> SPic
worldSPic cfig u =
(mempty :!: extraPics cfig u)
<> foldup propSPic (filtOn _prPos _props)
@@ -30,7 +31,7 @@ worldSPic cfig u =
<> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
<> foldup (drawCreature (u ^. uvWorld . cWorld . lWorld . items))
(filtOn _crPos _creatures)
<> foldup (Prelude.uncurry floorItemSPic) (IM.intersectionWith (,) (u^.uvWorld.cWorld.lWorld.items) (filtOn _flItPos (_floorItems)))
<> foldup (Prelude.uncurry floorItemSPic) (IM.intersectionWith (,) (u^.uvWorld.cWorld.lWorld.items) (filtOn _flItPos _floorItems))
<> foldup btSPic (filtOn _btPos _buttons)
<> foldup (mcSPic (u ^. uvWorld . cWorld . lWorld)) (filtOn _mcPos _machines)
<> foldMap' drawChasm (u ^. uvWorld . cWorld . chasms)
@@ -87,12 +88,12 @@ shiftDraw' fpos fdir fdraw x =
. rotateSP (fdir x)
$ fdraw x
cullPoint :: Configuration -> World -> Point2 -> Bool
cullPoint :: Config -> World -> Point2 -> Bool
cullPoint cfig w p
| debugOn Close_shape_culling cfig = pointInPolygon p (w ^. wCam . camBoundBox)
| otherwise = dist (w ^. wCam . camCenter) p < (w ^. wCam . camViewDistance)
extraPics :: Configuration -> Universe -> Picture
extraPics :: Config -> Universe -> Picture
extraPics cfig u =
setLayer FixedCoordLayer (fixedCoordPictures u)
<> foldMap drawTractorBeam (_tractorBeams lw)
@@ -109,8 +110,8 @@ extraPics cfig u =
<> foldMap drawLightSource (_lightSources lw)
<> foldMap ppDraw (_pressPlates lw)
<> viewClipBounds cfig w
<> debugDraw cfig w
<> foldMap (`_debugPic` u) (_uvDebug u) -- debug messages are in fixed coord pics
<> showEnabledDebugs cfig
<> foldMap _debugPic (_uvDebug u) -- debug messages are in fixed coord pics
where
w = u ^. uvWorld
lw = w ^. cWorld . lWorld
@@ -123,7 +124,7 @@ floorItemSPic itm flit =
uncurryV translateSPxy (_flItPos flit) $
rotateSP
(_flItRot flit)
(itemSPic $ itm)
(itemSPic itm)
btSPic :: Button -> SPic
btSPic bt =
src/Dodge/Room/Airlock.hs
+2
View File
@@ -3,6 +3,7 @@
{- Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock where
import Dodge.Placement.Instance.Analyser
import Dodge.Annotation.Data
import Dodge.Data.GenWorld
import Dodge.Default.Door
@@ -35,6 +36,7 @@ decontamRoom = do
\_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
, spanLightI (V2 (-2) 30) (V2 (-2) 70)
, analyser (RequireHealth 100) (PS 50 0) (PS (V2 70 50) 0)
]
& rmBound .~ [rectNSWE 75 15 0 40, switchcut]
where
src/Dodge/Room/LasTurret.hs
+3 -4
View File
@@ -42,7 +42,7 @@ lightSensInsideDoor i rm =
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
]
& rmOutPmnt . at i ?~ (sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100))
& rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)
lightSensByDoor :: Int -> Room -> Room
lightSensByDoor i rm =
@@ -52,7 +52,7 @@ lightSensByDoor i rm =
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
, heightWallPS (atFstLnkOutShiftInward 100) 30 covershape
]
& rmOutPmnt . at i ?~ (sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift))
& rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)
where
covershape = rectNSWE 10 (-10) (-20) 20
sensorshift (p, a) = (p +.+ rotateV a (V2 60 (-20)), a)
@@ -82,11 +82,10 @@ analyserByNthLink n proxreq i rm =
.++~ [ psPt (atNthLinkOut n) $ PutForeground $ verticalWire (V2 20 0) 0 80
]
& rmOutPmnt . at i ?~
( analyser
analyser
proxreq
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atNthLnkOutShiftBy n sensorshift)
)
where
sensorshift (p, a) = (p +.+ rotateV a (V2 (-30) (-10)), a)
src/Dodge/Room/SensorDoor.hs
+1 -1
View File
@@ -66,4 +66,4 @@ sensInsideDoor senseType i rm = rm
(textTerminal & tmCommands .:~ TCDamageCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
]
& rmOutPmnt . at i ?~ (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100))
& rmOutPmnt . at i ?~ sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)
src/Dodge/Room/Tutorial.hs
+6 -6
View File
@@ -1,9 +1,9 @@
module Dodge.Room.Tutorial (tutAnoTree,tutRezBox) where
module Dodge.Room.Tutorial where
import Dodge.Room.Room
import Dodge.Room.Corridor
import Dodge.Room.Airlock
import Dodge.Room.RoadBlock
import Dodge.Room.Room
import Dodge.Item.Held.Cane
import Dodge.Item.Ammo
import Dodge.Annotation.Data
@@ -42,15 +42,15 @@ import TreeHelp
tutAnoTree :: Annotation
tutAnoTree =
OnwardList $
OnwardList
[ AnTree $ return $ tToBTree "teststart" $ return $ cleatOnward corridor
, AnTree $ tutDrop
-- , AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
-- [ AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, AnTree corDoor
, AnTree $ tutRooms
, AnTree $ tutDrop
-- , AnTree $ pickupTut
-- , AnTree $ weaponTut
---- , AnTree $ pickupTut
---- , AnTree $ weaponTut
]
tutDrop :: State LayoutVars (MetaTree Room String)
src/Dodge/Room/Warning.hs
+3 -2
View File
@@ -52,10 +52,11 @@ addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str = addDoorToggleTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
addWarningTerminal str = addDoorToggleTerminal
(makeColorTermLine red "WARNING" : makeTermPara str)
lineOutputTerminal :: [TerminalLine] -> Terminal
lineOutputTerminal tls = defaultTerminal & tmBootLines .~ connectionBlurbLines tls
lineOutputTerminal tls = defaultTerminal & tmBootLines .~ textInputBlurb tls
moveToSideNthOutLink :: Int -> RoomPos -> Room -> Maybe (Point2, Float)
moveToSideNthOutLink i rp rm = do
src/Dodge/ScreenPos.hs
+2 -2
View File
@@ -9,10 +9,10 @@ import Picture.Base
fromTopLeft :: Point2 -> ScreenPos
fromTopLeft (V2 x y) = ScreenPos (V2 (-0.5) 0.5) (V2 x (- y))
translateScreenPos :: Configuration -> ScreenPos -> Picture -> Picture
translateScreenPos :: Config -> ScreenPos -> Picture -> Picture
translateScreenPos cfig = uncurryV translate . screenPosAbs cfig
screenPosAbs :: Configuration -> ScreenPos -> Point2
screenPosAbs :: Config -> ScreenPos -> Point2
screenPosAbs cfig sp = sp ^. spScreenOff * V2 w h + sp ^. spPixelOff
where
w = fromIntegral $ cfig ^. windowX
src/Dodge/SelectedClose.hs
+1 -1
View File
@@ -13,7 +13,7 @@ interactWithCloseObj e w = worldEventFlags . at InventoryChange ?~ () $ case e o
getSelectedCloseObj :: World -> Maybe (Either (NewInt ItmInt) Button)
getSelectedCloseObj w = do
(i, j, _) <- w ^? hud . hudElement . diSelection . _Just
Sel i j _ <- w ^? hud . diSelection . _Just
case i of
3 -> Left <$> w ^? hud . closeItems . ix j
5 -> do
src/Dodge/SelectionList.hs
+1 -1
View File
@@ -7,7 +7,7 @@ import Dodge.Data.Universe
import LensHelp
import Linear
getAvailableListLines :: ListDisplayParams -> Configuration -> Int
getAvailableListLines :: ListDisplayParams -> Config -> Int
getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight)
where
vgap = ldps ^. ldpVerticalGap
src/Dodge/SelectionSections.hs
+56 -99
View File
@@ -10,6 +10,8 @@ module Dodge.SelectionSections (
inverseSelNumPos,
) where
import Dodge.Data.HUD
import Dodge.Data.CardinalPoint
import qualified Data.IntSet as IS
import Control.Applicative
import qualified Control.Foldl as L
@@ -23,170 +25,131 @@ import Dodge.Data.SelectionList
import Dodge.ScreenPos
import Geometry.Data
scrollSelectionSections ::
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int,IS.IntSet) ->
Maybe (Int, Int,IS.IntSet)
scrollSelectionSections :: Int -> IMSS a -> Maybe Selection -> Maybe Selection
scrollSelectionSections yi sss msel
| yi == 0 = msel
| yi > 0 = foldl' (&) msel $ replicate yi (ssScrollUsing ssLookupUp sss)
| otherwise = foldl' (&) msel $ replicate (negate yi) (ssScrollUsing ssLookupDown sss)
nextInSectionSS ::
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, IS.IntSet) ->
Maybe (Int, Int, IS.IntSet)
nextInSectionSS :: IMSS a -> Maybe Selection -> Maybe Selection
nextInSectionSS = ssScrollUsing ssLookupNextMax
--setFirstPosSelectionSections :: SelectionSections a -> SelectionSections a
--setFirstPosSelectionSections sss = fromMaybe sss $ do
-- (i, j, _) <- ssLookupMin sss
-- return $ sss & sssExtra . sssSelPos ?~ (i, j)
ssScrollUsing ::
(Int -> Int -> IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)) ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, IS.IntSet) ->
Maybe (Int, Int, IS.IntSet)
ssScrollUsing g =
ssScrollMinOnFail
g
. fmap (ssItems %~ IM.filter _siIsSelectable)
(Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
IMSS a ->
Maybe Selection ->
Maybe Selection
ssScrollUsing g = ssScrollMinOnFail g . fmap (ssItems %~ IM.filter _siIsSelectable)
ssScrollMinOnFail ::
(Int -> Int -> IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)) ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, IS.IntSet) ->
Maybe (Int, Int, IS.IntSet)
ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> (i, j, q i j)) $ l <|> ssLookupMin sss
(Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
IMSS a ->
Maybe Selection ->
Maybe Selection
ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> Sel i j (q i j)) $ l <|> ssLookupMin sss
where
q i j = fromMaybe mempty $ do
(k,_,xs) <- msel ^? _Just
Sel k _ xs <- msel ^? _Just
guard $ j `IS.member` xs && i == k
return xs
l = do
(i, j, _) <- msel
Sel i j _ <- msel
f i j sss
ssSetCursor ::
(IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)) ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, IS.IntSet) ->
Maybe (Int, Int, IS.IntSet)
(IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
IMSS a ->
Maybe Selection ->
Maybe Selection
ssSetCursor f sss msel = fromMaybe msel $ do
(i, j, _) <- f sss
let newxs = fromMaybe mempty $ do
(k,_,xs) <- msel
Sel k _ xs <- msel
guard $ k == i && j `IS.member` xs
return xs
return $ Just (i, j,newxs)
return $ Just (Sel i j newxs)
ssLookupMax :: IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)
ssLookupMax :: IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupMax sss = do
(i, _) <- IM.lookupMax sss
ssLookupLE' i sss
ssLookupUp ::
Int ->
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupUp :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupUp i j sss = case ssLookupLT i j sss of
Nothing -> ssLookupMax sss
x -> x
ssLookupDown ::
Int ->
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupDown :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupDown i j sss = case ssLookupGT i j sss of
Nothing -> ssLookupMin sss
x -> x
ssLookupNextMax ::
Int ->
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupNextMax :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupNextMax i j sss = case ssLookupGT i j sss of
Just x@(i',j',_) | i' == i && j' > j -> Just x
_ -> ssLookupMaxInSection i sss <|> ssLookupDown i j sss
ssLookupMaxInSection :: Int -> IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupMaxInSection :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupMaxInSection i sss = do
ss <- sss ^? ix i . ssItems
(j,s) <- IM.lookupMax ss
return (i,j,s)
ssLookupLT ::
Int ->
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupLT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do
ss <- sss ^? ix i
(j', si) <- IM.lookupLT j (ss ^. ssItems)
return $ Just (i, j', si)
ssLookupLT' ::
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupLT' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupLT' i sss = do
(i', ss) <- IM.lookupLT i sss
case IM.lookupMax (ss ^. ssItems) of
Just (j', si) -> return (i', j', si)
Nothing -> ssLookupLT' i' sss
ssLookupLE' :: Int -> IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)
ssLookupLE' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupLE' i sss = do
(i', ss) <- IM.lookupLE i sss
case IM.lookupMax (ss ^. ssItems) of
Just (j', si) -> return (i', j', si)
Nothing -> ssLookupLT' i' sss
ssLookupMin :: IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)
ssLookupMin :: IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupMin sss = do
(i, _) <- IM.lookupMin sss
ssLookupGE' i sss
ssLookupGT ::
Int ->
Int ->
IM.IntMap (SelectionSection a) ->
Maybe (Int, Int, SelectionItem a)
ssLookupGT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupGT i j sss = fromMaybe (ssLookupGT' i sss) $ do
ss <- sss ^? ix i
(j', si) <- IM.lookupGT j (ss ^. ssItems)
return $ Just (i, j', si)
ssLookupGT' :: Int -> IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)
ssLookupGT' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupGT' i sss = do
(i', ss) <- IM.lookupGT i sss
case IM.lookupMin (ss ^. ssItems) of
Just (j', si) -> return (i', j', si)
Nothing -> ssLookupGT' i' sss
ssLookupGE' :: Int -> IM.IntMap (SelectionSection a) -> Maybe (Int, Int, SelectionItem a)
ssLookupGE' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupGE' i sss = do
(i', ss) <- IM.lookupGE i sss
case IM.lookupMin (ss ^. ssItems) of
Just (j', si) -> return (i', j', si)
Nothing -> ssLookupGT' i' sss
selSecSelSize :: Int -> Int -> IM.IntMap (SelectionSection a) -> Maybe Int
selSecSelSize :: Int -> Int -> IMSS a -> Maybe Int
selSecSelSize i j = (^? ix i . ssItems . ix j . siHeight)
-- need to check that the vertical gap is correctly put in here
posSelSecYint :: Configuration -> ListDisplayParams -> Float -> Int
posSelSecYint :: Config -> ListDisplayParams -> Float -> Int
posSelSecYint cfig ldp y = floor $ (y0 - y) / (20 / ldp ^. ldpScale + ldp ^. ldpVerticalGap)
where
V2 _ y0 = screenPosAbs cfig (ldp ^. ldpPos)
selSecYint :: Int -> Int -> IM.IntMap (SelectionSection a) -> Maybe Int
selSecYint :: Int -> Int -> IMSS a -> Maybe Int
selSecYint i j sss = do
ss <- sss ^? ix i
return . (secpos +)
@@ -198,26 +161,28 @@ selSecYint i j sss = do
where
secpos = sum . fmap _ssShownLength . fst $ IM.split i sss
inverseSelSecYint :: Int -> IM.IntMap (SelectionSection a) -> Maybe (Int, Int)
inverseSelSecYint yint sss = do
((i, ss), othersss) <- IM.minViewWithKey sss
let l = _ssShownLength ss
if l <= yint
then inverseSelSecYint (yint - l) othersss
else do
let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
(j,_) <- L.fold (L.find (\(_,x) -> x - _ssOffset ss > yint)) $ IM.toList ls
return (i, j)
inverseSelSecYint :: Int -> IMSS a -> XInfinity (Int, Int)
inverseSelSecYint yint sss
| yint < 0 = NegInf
| otherwise = fromMaybe PosInf $ do
((i, ss), othersss) <- IM.minViewWithKey sss
let l = _ssShownLength ss
if l <= yint
then return $ inverseSelSecYint (yint - l) othersss
else do
let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
(j,_) <- L.fold (L.find (\(_,x) -> x - _ssOffset ss > yint)) $ IM.toList ls
return $ NonInf (i, j)
inverseSelSecYintXPosCheck ::
Configuration ->
Config ->
ListDisplayParams ->
Float ->
Int ->
IM.IntMap (SelectionSection a) ->
IMSS a ->
Maybe (Int,Int)
inverseSelSecYintXPosCheck cfig ldp x yint sss = do
(i,j) <- inverseSelSecYint yint sss
inverseSelSecYintXPosCheck cfig ldp x yint sss = do
(i,j) <- inverseSelSecYint yint sss ^? nonInf
let V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos)
sindent <- sss ^? ix i . ssIndent
itindent <- sss ^? ix i . ssItems . ix j . siOffX
@@ -225,14 +190,6 @@ inverseSelSecYintXPosCheck cfig ldp x yint sss = do
guard $ x - x1 < 160 && x > x1
return (i,j)
inverseSelNumPos ::
Configuration ->
ListDisplayParams ->
IM.IntMap (SelectionSection a) ->
Point2 ->
Maybe (Int, Int)
inverseSelNumPos cfig ldp sss (V2 x y) =
inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y) sss
--getIthPos :: Int -> IM.IntMap (SelectionItem a) -> Int
--getIthPos i sm = sum . fmap _siHeight . fst $ IM.split i sm
inverseSelNumPos :: Config -> ListDisplayParams -> Point2 -> IMSS a -> Maybe (Int, Int)
inverseSelNumPos cfig ldp (V2 x y) =
inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y)
src/Dodge/SelectionSections/Draw.hs
+3 -3
View File
@@ -16,7 +16,7 @@ import Picture.Base
drawSelectionSections ::
IM.IntMap (SelectionSection a) ->
ListDisplayParams ->
Configuration ->
Config ->
Picture
drawSelectionSections sss ldp cfig =
translateScreenPos cfig (ldp ^. ldpPos) $
@@ -36,7 +36,7 @@ drawSSCursor ::
IM.IntMap (SelectionSection a) ->
ListDisplayParams ->
CursorDisplay ->
Configuration ->
Config ->
Maybe (Int, Int) ->
Picture
drawSSCursor sss ldp curs cfig =
@@ -49,7 +49,7 @@ drawSSMultiCursor ::
Maybe Int ->
ListDisplayParams ->
CursorDisplay ->
Configuration ->
Config ->
Picture
drawSSMultiCursor sss msel mextra ldp curs cfig = translateScreenPos cfig (ldp ^. ldpPos)
. fold
src/Dodge/SoundLogic/LoadSound.hs
+1 -1
View File
@@ -25,7 +25,7 @@ loadSounds = do
putStrLn $ show y <> " channels assigned to group 1"
fmap IM.fromList $ mapM loadSound $ zip [0..] soundPathList
where
nchans = 64::Int
nchans = 128::Int
loadMusic :: IO (IM.IntMap Mix.Music)
loadMusic = do
src/Dodge/Terminal.hs
+4 -26
View File
@@ -2,11 +2,10 @@
module Dodge.Terminal (
makeTermLine,
connectionBlurbLines,
textInputBlurb,
textTerminal,
simpleTermMessage,
damageCodeCommand,
sensorCommand,
makeColorTermLine,
makeTermPara,
terminalReturnEffect,
@@ -16,7 +15,6 @@ module Dodge.Terminal (
tlDoEffect,
) where
import Dodge.Item.Display
import Color
import Data.Char
import qualified Data.List as List
@@ -33,19 +31,16 @@ import LensHelp
import Sound.Data
textTerminal :: Terminal
textTerminal = defaultTerminal{_tmBootLines = connectionBlurb}
textTerminal = defaultTerminal{_tmBootLines = textInputBlurb []}
connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
connectionBlurbLines tls =
textInputBlurb :: [TerminalLine] -> [TerminalLine]
textInputBlurb tls =
[ termSoundLine computerBeepingS
, TLine 0 [TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor] TmWdId
]
++ tls
++ [TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput ""))]
connectionBlurb :: [TerminalLine]
connectionBlurb = connectionBlurbLines []
termSoundLine :: SoundID -> TerminalLine
termSoundLine sid = TLine 0 [] (TmWdWdTermSound sid)
@@ -61,7 +56,6 @@ getCommand w tm = \case
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
TCBase -> quitCommand <> toggleCommands tm
TCDamageCommand -> damageCodeCommand w tm
TCSensorInfo -> sensorCommand w tm
damageCodeCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
damageCodeCommand w _
@@ -81,22 +75,6 @@ decodeSensorType st w = fromMaybe [] $ do
x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st
return [makeTermLine $ show x]
-- ugly
sensorCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
sensorCommand w tm = PTE.singleton "SENSOR" $ fromMaybe mempty $ do
ProximitySensor _ _ r b <- w ^? cWorld . lWorld . machines . ix (tm ^. tmMachineID) . mcType . _McSensor
return $ PTE.fromList
[ ("", makeTermPara $ sensorReqToString r b)
]
sensorReqToString :: ProximityRequirement -> Bool -> String
sensorReqToString pr = \case
True -> "SENSOR TEST PASSED."
False -> "SENSOR REQUIRES: " ++ case pr of
RequireHealth x -> "HEALTH ABOVE " ++ show x
RequireEquipment x -> itemBaseName x
toggleCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
toggleCommands tm
| null ts = mempty
src/Dodge/Terminal/Color.hs
+2 -3
View File
@@ -1,6 +1,4 @@
module Dodge.Terminal.Color (
termScreenColor,
) where
module Dodge.Terminal.Color (termScreenColor) where
import Dodge.Data.Terminal.Status
import Dodge.Data.Terminal
@@ -14,3 +12,4 @@ termScreenColor tm = case tm ^. tmStatus of
TerminalTextInput _ -> Just green
TerminalPressTo{} -> Just green
TerminalLineRead -> Just white
TerminalWaiting -> Just green
src/Dodge/Terminal/Type.hs
+1 -4
View File
@@ -1,7 +1,4 @@
module Dodge.Terminal.Type (
getPromptTM,
getMaxLinesTM,
) where
module Dodge.Terminal.Type ( getPromptTM, getMaxLinesTM) where
getPromptTM :: String
getPromptTM = "> "
src/Dodge/Update.hs
+26 -41
View File
@@ -333,24 +333,22 @@ updateMagnets lw =
checkTermDist :: World -> World
checkTermDist w = fromMaybe w $ do
tmid <- w ^? hud . hudElement . subInventory . termID
tmid <- w ^? hud . subInventory . termID
btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID
btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos
guard $ dist btpos (_crPos $ you w) > 40
return $ w & hud . hudElement . subInventory .~ NoSubInventory
return $ w & hud . subInventory .~ NoSubInventory
updateMouseContext :: Configuration -> Universe -> Universe
updateMouseContext :: Config -> Universe -> Universe
updateMouseContext cfig u = case u ^? uvScreenLayers . ix 0 of
Just screen -> u & uvWorld . input . mouseContext .~ getMenuMouseContext screen u
Nothing -> updateMouseContextGame cfig u
Nothing -> u & uvWorld . input . mouseContext %~ updateMouseContextGame cfig u
updateMouseContextGame :: Configuration -> Universe -> Universe
updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of
OverInvDrag i _ _ _ -> u & uvWorld . input . mouseContext .~ invdrag i
OverInvDragSelect{} -> u
_ ->
u & uvWorld . input . mouseContext
.~ fromMaybe aimcontext (isrotatedrag <|> overinv <|> overcomb <|> overterm)
updateMouseContextGame :: Config -> Universe -> MouseContext -> MouseContext
updateMouseContextGame cfig u = \case
OverInvDrag i _ -> OverInvDrag i (inverseSelNumPos cfig invDP mpos disss)
x@OverInvDragSelect{} -> x
_ -> fromMaybe aimcontext (isrotatedrag <|> overinv <|> overcomb <|> overterm)
where
w = u ^. uvWorld
isrotatedrag = do
@@ -359,41 +357,31 @@ updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of
guard $ t1 > t2
return MouseGameRotate
aimcontext
-- | Just t1 <- w ^. input . mouseButtons . at ButtonLeft
-- , Just t2 <- w ^. input . mouseButtons . at ButtonRight
-- , t1 > t2 = MouseGameRotate
| ButtonRight `M.member` (w ^. input . mouseButtons) = MouseAiming
| otherwise = MouseInGame
mpos = w ^. input . mousePos
invdrag i' = fromMaybe (OverInvDrag i' Nothing Nothing Nothing) $ do
sss <- w ^? hud . hudElement . diSections
let yint = posSelSecYint cfig invDP (mpos ^. _y)
(i, j) <- inverseSelNumPos cfig invDP sss mpos
let above = inverseSelSecYint (yint - 1) sss
bneath = inverseSelSecYint (yint + 1) sss
return $ OverInvDrag i' (Just (i, j)) above bneath
disss = w ^. hud . diSections
overinv = do
sss <- w ^? hud . hudElement . diSections
selpos@(i, j) <- inverseSelNumPos cfig invDP sss mpos
case w ^? hud . hudElement . subInventory . ciSelection of
selpos@(i, j) <- inverseSelNumPos cfig invDP mpos disss
case w ^? hud . subInventory . ciSelection of
Just _ | i == 0 -> return $ OverCombFiltInv selpos
Just _ -> Nothing
_ -> do
guard $ ButtonRight `M.notMember` (w ^. input . mouseButtons)
guard =<< sss ^? ix i . ssItems . ix j . siIsSelectable
guard =<< disss ^? ix i . ssItems . ix j . siIsSelectable
return $ OverInvSelect selpos
overcomb = do
sss <- w ^? hud . hudElement . subInventory . ciSections
(xl, xr, _) <- w ^? hud . hudElement . subInventory . ciSelection . _Just
sss <- w ^? hud . subInventory . ciSections
Sel xl xr _ <- w ^? hud . subInventory . ciSelection . _Just
let msel = (xl, xr)
let mpossel = inverseSelNumPos cfig secondColumnParams sss (w ^. input . mousePos)
let mpossel = inverseSelNumPos cfig secondColumnLDP (w ^. input . mousePos) sss
return $ case mpossel of
Nothing -> OverCombEscape
Just (-1, i) | (-1, i) == msel -> OverCombFilter
Just x | x == msel -> OverCombCombine x
Just x -> OverCombSelect x
overterm = do
tmid <- w ^? hud . hudElement . subInventory . termID
tmid <- w ^? hud . subInventory . termID
tm <- w ^? cWorld . lWorld . terminals . ix tmid
return $
if isOverTerminalScreen cfig mpos
@@ -405,20 +393,20 @@ getMenuMouseContext screen u = case screen ^. scOptions of
[] -> NoMouseContext
_ -> fromMaybe MouseMenuCursor $ do
ymax <- length <$> screen ^? scSelectionList
yi <- ldpVerticalSelection (u ^. uvConfig) menuDisplayParams (u ^. uvWorld . input . mousePos)
yi <- ldpSelection (u ^. uvConfig) menuLDP (u ^. uvWorld . input . mousePos)
guard (yi >= 0 && yi < ymax)
return $ case u ^? uvScreenLayers . _head . scSelectionList . ix yi . siIsSelectable of
return $ case screen ^? scSelectionList . ix yi . siIsSelectable of
Just True -> MouseMenuClick yi
_ -> NoMouseContext
isOverTerminalScreen :: Configuration -> Point2 -> Bool
isOverTerminalScreen :: Config -> Point2 -> Bool
isOverTerminalScreen cfig (V2 x y) =
x <= xmax
&& x >= xmin - 5
&& y <= ymax + 5
&& y >= ymin
where
ldp = secondColumnParams
ldp = secondColumnLDP
V2 xmin ymax = screenPosAbs cfig (ldp ^. ldpPos)
tsize = fromIntegral $ getMaxLinesTM + 1
s = 5 + tsize * (20 * ldp ^. ldpScale + ldp ^. ldpVerticalGap)
@@ -437,8 +425,7 @@ advanceScrollAmount =
updatePastWorlds :: World -> World
updatePastWorlds w =
w
& pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
doWorldEvents :: World -> World
doWorldEvents w =
@@ -490,6 +477,7 @@ pbFlicker pt =
zoneClouds :: World -> World
zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds)
zoneDusts :: World -> World
zoneDusts w = w & dsZoning .~ foldl' (flip zoneDust) mempty (w ^. cWorld . lWorld . dusts)
@@ -506,7 +494,7 @@ tmUpdate tm w = fromMaybe w $ do
w & pointTermParams
%~ ( (tmFutureLines %~ tail)
. (tmDisplayedLines %~ take getMaxLinesTM . (map displayTerminalLineString tls ++))
-- . (tmDisplayedLines %~ (map displayTerminalLineString tls ++))
-- . (tmDisplayedLines %~ (map displayTerminalLineString tls ++))
)
& doTmWdWd g tm
where
@@ -632,10 +620,7 @@ updatePulseLaser pz = case pz ^. pzTimer of
5 -> (Endo f, [pz & pzTimer -~ 1])
_ -> (Endo g, [pz & pzTimer -~ 1])
where
f w =
dodam
thHit
w
f w = dodam thHit w
& cWorld . lWorld . flares <>~ drawLaser cyan (sp : ps)
where
(thHit, ps) = reflectPulseLaserAlong phasev sp xp w
@@ -657,7 +642,7 @@ updatePulseLaser pz = case pz ^. pzTimer of
xp = sp +.+ 800 *.* unitVectorAtAngle dir
g w = w & cWorld . lWorld . flares <>~ drawLaser cyan (sp : ps)
where
(_, ps) = reflectLaserAlong phasev sp xp w
(_, ps) = reflectPulseLaserAlong phasev sp xp w
randWallReflect :: RandomGen g => Float -> Wall -> State g Float
randWallReflect a wl = randPeaked a1 outa a2
src/Dodge/Update/Camera.hs
+11 -9
View File
@@ -27,12 +27,12 @@ import SDL (MouseButton (..))
{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
update where your avatar's view is from. -}
updateCamera :: Configuration -> World -> World
updateCamera :: Config -> World -> World
updateCamera cfig w = case w ^. wCam . camControl of
CamInGame{} -> updateInGameCamera cfig w
CamFloat -> updateFloatingCamera cfig w
updateFloatingCamera :: Configuration -> World -> World
updateFloatingCamera :: Config -> World -> World
updateFloatingCamera cfig w =
w
& updateBounds cfig
@@ -76,7 +76,7 @@ zoomFloatingCamera theinput
-- the 39/40 is taken from zoomSpeed
updateInGameCamera :: Configuration -> World -> World
updateInGameCamera :: Config -> World -> World
updateInGameCamera cfig w =
w
& updateBounds cfig
@@ -84,7 +84,7 @@ updateInGameCamera cfig w =
& rotateCamera cfig
& over wCam (setViewDistance cfig) -- I think this should be updated after the zoom?
moveZoomCamera :: Configuration -> Input -> Creature -> World -> Camera -> Camera
moveZoomCamera :: Config -> Input -> Creature -> World -> Camera -> Camera
moveZoomCamera cfig theinput cr w campos =
campos
& camCenter .~ fromMaybe (_crPos cr +.+ offset) mremotepos
@@ -127,7 +127,9 @@ moveZoomCamera cfig theinput cr w campos =
| curZoom > idealZoom + 0.01 = ((zoomOutSpeed -1) * curZoom + idealZoom) / zoomOutSpeed
| curZoom < idealZoom - 0.01 = ((zoomInSpeed -1) * curZoom + idealZoom) / zoomInSpeed
| otherwise = idealZoom
wallZoom = min4 (campos ^. camBoundDist)
wallZoom = min4 (f (campos ^. camBoundDist))
f (a,b,c,d) = (a+bordersize,b-bordersize,c+bordersize,d-bordersize)
bordersize = 20
min4 (a, b, c, d) = minimum [hh / maxd a, hh / maxd (- b), hw / maxd c, hw / maxd (- d)]
maxd = max distFromEqmnt
distFromEqmnt = viewDistanceFromItems cr
@@ -192,7 +194,7 @@ heldAimZoom = \case
viewDistanceFromItems :: Creature -> Float
viewDistanceFromItems _ = 1
rotateCamera :: Configuration -> World -> World
rotateCamera :: Config -> World -> World
rotateCamera cfig w
| MouseGameRotate <- w ^. input . mouseContext
, Just rotation <-
@@ -231,7 +233,7 @@ clipZoom ::
Float
clipZoom = min 20 . max 0.2
setViewDistance :: Configuration -> Camera -> Camera
setViewDistance :: Config -> Camera -> Camera
setViewDistance cfig w =
w & camViewDistance
.~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / (w ^. camZoom)
@@ -243,7 +245,7 @@ farWallDistDirection p w = boundPoints $ map f $ getViewpoints p (_cWorld w)
wls q = filter wlIsOpaque $ wlsNearSeg p q w
findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
findBoundDists :: Configuration -> World -> (Float, Float, Float, Float)
findBoundDists :: Config -> World -> (Float, Float, Float, Float)
findBoundDists cfig w
| debugOn Bound_box_screen cfig = (hh, - hh, hw, - hw)
| otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (w ^. wCam . camViewFrom) w
@@ -253,7 +255,7 @@ findBoundDists cfig w
-- this probably doesn't need to be updated every frame,
-- though I'm not sure how often it should be updated
updateBounds :: Configuration -> World -> World
updateBounds :: Config -> World -> World
updateBounds cfig w = case (w ^. cWorld . cClock) `mod` 5 of
0 ->
w

Some files were not shown because too many files have changed in this diff Show More