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

Cleanup

Browse Source
This commit is contained in:
justin
2025-08-27 18:55:25 +01:00
parent 86696deb56
commit 40d2d316cb
35 changed files with 316 additions and 431 deletions
Download Patch File Download Diff File Expand all files Collapse all files
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/Creature/Action.hs
+1 -1
View File
@@ -168,7 +168,7 @@ 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
src/Dodge/Creature/HandPos.hs
-8
View File
@@ -36,14 +36,6 @@ equipSitePQ = \case
translatePointToRightHand :: Creature -> Point3 -> Point3
translatePointToRightHand cr p = fst (rightHandPQ cr `Q.comp` (p,Q.qID))
--equipSitePQ :: EquipSite -> IM.IntMap Item -> Creature -> Point3Q
--equipSitePQ = \case
-- OnRightWrist -> rightHandPQ
-- OnLeftWrist -> leftHandPQ
-- OnBack -> backPQ
-- OnChest -> chestPQ
-- _ -> undefined
rightHandPQ :: Creature -> Point3Q
rightHandPQ cr
| oneH cr = (V3 11 (-3) 20, Q.qID)
src/Dodge/Creature/Impulse/UseItem.hs
+1 -1
View File
@@ -19,7 +19,7 @@ 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
src/Dodge/Creature/Test.hs
-3
View File
@@ -87,9 +87,6 @@ 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
src/Dodge/DisplayInventory.hs
+2 -2
View File
@@ -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
src/Dodge/Equipment.hs
+11 -7
View File
@@ -13,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
@@ -49,11 +50,14 @@ setWristShieldPos itm cr w = w & moveWallIDUnsafe i wlline
where
i = _itParamID $ _itParams itm
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 x -> translateToES cr x -- . g
_ -> undefined
-- g
-- | twists cr = (+.+.+ V3 (-5) 10 0)
-- | otherwise = id
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/Euse.hs
+1 -1
View File
@@ -33,7 +33,7 @@ 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
i = _itParamID $ _itParams itm
wlline = (f (V3 (-10) 7 0), f (V3 10 7 0))
src/Dodge/Floor.hs
+1 -1
View File
@@ -128,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
+24 -33
View File
@@ -419,8 +419,7 @@ itemSidePush = \case
applyInvLock :: Item -> Creature -> World -> World
applyInvLock itm cr = case itemInvLock itm of
i
| i > 0 && cid == 0 ->
i | i > 0 && cid == 0 ->
(cWorld . lWorld . delayedEvents .:~ (i, UnlockInv)) . lockInv
_ -> id
where
@@ -668,12 +667,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
@@ -779,11 +777,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
@@ -1118,8 +1112,13 @@ mcUseHeld hit = case hit of
LASER -> mcShootLaser
_ -> mcShootAuto
useGasParams :: Maybe (NewInt InvInt)
-> Muzzle -> LocationDT OItem -> Creature -> World -> World
useGasParams ::
Maybe (NewInt InvInt) ->
Muzzle ->
LocationDT OItem ->
Creature ->
World ->
World
useGasParams mmagid mz loc cr w =
w
& createGas gastype pressure pos dir cr
@@ -1319,25 +1318,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 +1344,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
+7 -15
View File
@@ -6,27 +6,19 @@ 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 . subInventory of
Just NoSubInventory{} -> case he ^? diSelection . _Just . slSec of
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 . slSec of
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} -> return
$ cWorld . lWorld . terminals . ix tmid . tmStatus . tiText
_ -> Nothing
where
he = w ^. hud
src/Dodge/Inventory/Add.hs
+1 -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
@@ -44,7 +43,7 @@ tryPutItemInInv cid itid w = do
where
updateselectionextra i
| cid == 0 = (hud . diSelection . _Just . slSet %~ IS.map (f i))
. (hud . diSelection . _Just . slInt %~ (f i))
. (hud . diSelection . _Just . slInt %~ f i)
| otherwise = id
f j i | i >= _unNInt j = i + 1
| otherwise = i
src/Dodge/Inventory/RBList.hs
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
module Dodge.Inventory.RBList (
updateRBList,
src/Dodge/Item/Draw.hs
+16 -29
View File
@@ -1,29 +1,26 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Item.Draw (
itemSPic,
itemEquipPict,
) where
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 :: Creature -> DTree CItem -> SPic
itemEquipPict cr itmtree
| --Just i <- itm ^? itLocation . ilInvID
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)
| 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
@@ -31,23 +28,13 @@ itemEquipPict cr itmtree
equipAttachPos :: EquipItemType -> Point3Q
equipAttachPos = \case
BATTERYPACK -> (V3 (-8) 0 10, Q.qID)
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 -> Creature -> Point3Q -> SPic -> SPic
equipPosition es cr q = overPosSP
(\x -> fst $ equipSitePQ es cr `Q.comp` q `Q.comp` (x,Q.qID))
-- case epos of
-- --OnLeftWrist -> translateToLeftWrist cr
-- --OnRightWrist -> translateToRightWrist cr
-- OnLeftWrist -> overPosSP (translateToES cr OnLeftWrist)
-- OnRightWrist -> overPosSP (translateToES cr OnRightWrist)
-- OnLegs ->
-- translateToLeftLeg cr
-- <> translateToRightLeg cr-- (mirrorSPxz sh)
-- OnHead -> overPosSP (translateToES cr OnHead)
-- OnChest -> overPosSP (translateToES cr OnChest)
-- OnBack -> overPosSP (\x -> fst $ backPQ cr `Q.comp` (p + x,Q.qID))
equipPosition es cr q =
overPosSP
(\x -> fst $ equipSitePQ es cr `Q.comp` q `Q.comp` (x, Q.qID))
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/Machine/Update.hs
+1 -1
View File
@@ -154,7 +154,7 @@ 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)
((\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr)
_ -> False
where
cr = you w
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/ShapePicture.hs
+3 -2
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
@@ -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)
@@ -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/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
+2 -2
View File
@@ -42,9 +42,9 @@ import TreeHelp
tutAnoTree :: Annotation
tutAnoTree =
OnwardList $
OnwardList
[ AnTree $ return $ tToBTree "teststart" $ return $ cleatOnward corridor
-- , AnTree $ tutDrop
, AnTree $ tutDrop
---- , AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
-- , AnTree corDoor
-- , AnTree $ tutRooms
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/Terminal.hs
+4 -7
View File
@@ -2,7 +2,7 @@
module Dodge.Terminal (
makeTermLine,
connectionBlurbLines,
textInputBlurb,
textTerminal,
simpleTermMessage,
damageCodeCommand,
@@ -33,19 +33,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)
src/Dodge/Terminal/Color.hs
+1 -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
src/Dodge/Update.hs
-1
View File
@@ -364,7 +364,6 @@ updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of
mpos = w ^. input . mousePos
disss = w ^. hud . diSections
invdrag i' = fromMaybe (OverInvDrag i' Nothing) $ do
-- sss <- w ^? hud . diSections
(i, j) <- inverseSelNumPos cfig invDP mpos disss
return $ OverInvDrag i' (Just (i, j))
overinv = do
src/Dodge/Update/Input/InGame.hs
+1 -1
View File
@@ -545,7 +545,7 @@ tryCombine (i, j) w = fromMaybe w $ do
. ciSections . ix i . ssItems . ix j . siPayload . _Just
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
return $
(createItemYou it (foldr (destroyInvItem 0 . NInt) w (sort is)))
createItemYou it (foldr (destroyInvItem 0 . NInt) w (sort is))
& soundStart InventorySound p wrench1S Nothing
& hud . diSelection . _Just . slSet .~ mempty
src/Dodge/Update/Scroll.hs
+33 -48
View File
@@ -3,22 +3,22 @@ module Dodge.Update.Scroll (
updateWheelEvent,
) where
import NewInt
import Control.Applicative
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
import Dodge.Data.Terminal.Status
import Dodge.Data.EquipType
import Padding
import Control.Monad
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Base
import Dodge.Data.EquipType
import Dodge.Data.Terminal.Status
import Dodge.Data.Universe
import Dodge.Inventory
import Dodge.SelectionSections
import Dodge.Terminal
import Geometry
import LensHelp
import NewInt
import Padding
import SDL
-- yi should be nonzero
@@ -33,7 +33,7 @@ updateWheelEvent yi w = case w ^. hud . subInventory of
-- yi should be nonzero
updateBaseWheelEvent :: Int -> World -> World
updateBaseWheelEvent yi w
-- | Just True <- w ^? cWorld . lWorld . creatures . ix 0 . crInvLock = w
-- | Just True <- w ^? cWorld . lWorld . creatures . ix 0 . crInvLock = w
| Just True <- w ^? cWorld . lWorld . lInvLock = w
| bdown ButtonRight = case _rbState w of
EquipOptions{} -> w & rbState . opSel %~ scrollRBOption yi rbscrollmax
@@ -56,8 +56,9 @@ selectedItemScroll yi w = do
itemScroll :: Int -> Item -> World -> World
itemScroll yi itm w
| Just xs <- itm ^? itUse . uaParams . apProjectiles = w
& itmlens . itUse . uaParams . apProjectiles .~ rotateList yi xs
| Just xs <- itm ^? itUse . uaParams . apProjectiles =
w
& itmlens . itUse . uaParams . apProjectiles .~ rotateList yi xs
| ATTACH ZOOMSCOPE <- itm ^. itType = updateScopeZoom (itm ^. itID) w
| HELD ALTERIFLE <- itm ^. itType
, yi /= 0 =
@@ -65,8 +66,9 @@ itemScroll yi itm w
& itmlens . itParams . alteRifleSwitch
%~ ((`mod` 2) . (+ 1))
| isJust $ itm ^? itScroll . itsInt = w & itmlens . itScroll . itsInt +~ yi
| Just y <- itm ^? itScroll . itsMax = w & itmlens . itScroll . itsRangeInt
%~ ((`mod` y) . (+ yi))
| Just y <- itm ^? itScroll . itsMax =
w & itmlens . itScroll . itsRangeInt
%~ ((`mod` y) . (+ yi))
| otherwise = w
where
--itmlens = cWorld . lWorld . creatures . ix 0 . crInv . ix invid
@@ -140,77 +142,60 @@ terminalWheelEvent yi tmid w
wrapdown s coms = PTE.findPredecessor s coms <|> PTE.findMax coms
f tm = fromMaybe tm $ do
let coms = getCommands w tm
x <- tm ^? tmStatus . tiText
x <- tm ^? tmStatus . tiText
let s = fromMaybe "" $ x ^? to words . ix 0
(s',_) <- dowrap s coms
(s', _) <- dowrap s coms
return $ tm & tmStatus . tiText .~ s'
g tm = fromMaybe tm $ do
let coms = getCommands w tm
x <- tm ^? tmStatus . tiText
let s = fromMaybe "" $ x ^? to words . ix 0
y = fromMaybe "" $ x ^? to words . ix 1
-- (s',m) <- fmap (s,) (PTE.lookup s coms) <|> dowrap s coms
-- (arg,_) <- dowrap y m
(s',arg,_) <- if yi > 0 then doubleFindSucc s y coms <|> doubleFindMin coms
else doubleFindPred s y coms <|> doubleFindMax coms
(s', arg, _) <-
if yi > 0
then doubleFindSucc s y coms <|> doubleFindMin coms
else doubleFindPred s y coms <|> doubleFindMax coms
return $ tm & tmStatus . tiText .~ s' ++ " " ++ arg
--case tm ^? tmInput . tiSel of
-- Nothing -> tm & tmInput . tiSel .~ (0, 0)
-- Just (i, _) ->
-- let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
-- in tm & setInput newi 0
-- updatetermsubsel tm = case tm ^? tmInput . tiSel of
-- Nothing -> tm & tmInput . tiSel .~ (0, 0)
-- Just (i, j) ->
-- let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
-- in tm & setInput i newj
-- setInput i j tm =
-- tm
-- & tmInput . tiSel .~ (i, j)
-- & tmStatus . tiText .~ comstr ++ arg
-- where
-- comstr = scrollCommandStrings w tm !! i
-- tc = scrollCommands tm !! i
-- arg = getArguments' tc tm w !! j
doubleFindMin :: (Enum a,Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
doubleFindMin :: (Enum a, Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a], [b], c)
doubleFindMin m = do
(x,n) <- PTE.findMin m
(x, n) <- PTE.findMin m
case PTE.findMin n of
Just (y,z) -> Just (x,y,z)
Just (y, z) -> Just (x, y, z)
Nothing -> Nothing
doubleFindSucc :: (Enum a,Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
doubleFindSucc :: (Enum a, Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a], [b], c)
doubleFindSucc xs ys m = case PTE.lookup xs m of
Just m' -> case PTE.findSuccessor ys m' of
Just (ys',z) -> Just (xs,ys',z)
Just (ys', z) -> Just (xs, ys', z)
Nothing -> dfs xs m
Nothing -> dfs xs m
where
dfs xs' m' = case PTE.findSuccessor xs' m' of
Just (xs'',n) -> case PTE.findMin n of
Just (ys',z) -> Just (xs'',ys',z)
Just (xs'', n) -> case PTE.findMin n of
Just (ys', z) -> Just (xs'', ys', z)
Nothing -> dfs xs'' m'
Nothing -> Nothing
-- there are edge cases where this doesn't behave as might be expected
doubleFindMax :: (Enum a,Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
doubleFindMax :: (Enum a, Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a], [b], c)
doubleFindMax m = do
(x,n) <- PTE.findMax m
(x, n) <- PTE.findMax m
case PTE.findMax n of
Just (y,z) -> Just (x,y,z)
Just (y, z) -> Just (x, y, z)
Nothing -> Nothing
doubleFindPred :: (Enum a,Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
doubleFindPred ::
(Enum a, Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a], [b], c)
doubleFindPred xs ys m = case PTE.lookup xs m of
Just m' -> case PTE.findPredecessor ys m' of
Just (ys',z) -> Just (xs,ys',z)
Just (ys', z) -> Just (xs, ys', z)
Nothing -> dfs xs m
Nothing -> dfs xs m
where
dfs xs' m' = case PTE.findPredecessor xs' m' of
Just (xs'',n) -> case PTE.findMax n of
Just (ys',z) -> Just (xs'',ys',z)
Just (xs'', n) -> case PTE.findMax n of
Just (ys', z) -> Just (xs'', ys', z)
Nothing -> dfs xs'' m'
Nothing -> Nothing
src/Dodge/WorldEffect.hs
+3 -3
View File
@@ -93,9 +93,9 @@ doTmWdWd tmwdwd = case tmwdwd of
TmWdId -> const id
TmWdWdPowerDownTerminal -> resetTerminal TerminalOff
TmWdWdDeactivateTerminal -> resetTerminal TerminalDeactivated
TmWdWdTermSound sid -> \tm w ->
let tpos = fromMaybe 0 $ w ^? cWorld . lWorld . buttons . ix (_tmButtonID tm) . btPos
in soundStart TerminalSound tpos sid Nothing w
TmWdWdTermSound sid -> \tm w -> fromMaybe w $ do
tpos <- w ^? cWorld . lWorld . buttons . ix (_tmButtonID tm) . btPos
return $ soundStart TerminalSound tpos sid Nothing w
TmWdWdDoDeathTriggers -> doDeathTriggers
TmWdWdfromWdWd f -> \_ -> doWdWd f