diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 424782948..45ed259f9 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -11,6 +11,7 @@ import FoldableHelp import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens +import qualified FoldlHelp as L hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} @@ -71,12 +72,36 @@ furthestPointWalkable p1 p2 ws . safeMinimumOn (dist p1) $ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws +collideDirectionIndirect + :: Float -- ^max distance to look + -> Point2 -- ^start point + -> Point2 -- ^point in direction + -> IM.IntMap Wall + -> Float +{-# INLINE collideDirectionIndirect #-} +collideDirectionIndirect d p1 p2 wls + = fromMaybe d + $ + ( L.fold + . L.prefilter (not . _wlIsSeeThrough) + . L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine) + ) L.minimum + wls + where + p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1) + collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 {-# INLINE collidePointIndirect #-} -collidePointIndirect p1 p2 - = safeMinimumOn (dist p1) - . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) - . IM.filter (not . _wlIsSeeThrough) +collidePointIndirect p1 p2 + = L.fold + . L.prefilter (not . _wlIsSeeThrough) + . L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine) + $ L.minimumOn (dist p1) +--collidePointIndirect p1 p2 +-- = safeMinimumOn (dist p1) +-- . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) +-- . IM.filter (not . _wlIsSeeThrough) + {- | Checks to see whether someone can fire bullets effectively between two points. - Not sure if this needs vision as well, need to make this uniform. -} collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 diff --git a/src/Dodge/Creature/ShadowBox.hs b/src/Dodge/Creature/ShadowBox.hs index d0e6d2558..f751bb173 100644 --- a/src/Dodge/Creature/ShadowBox.hs +++ b/src/Dodge/Creature/ShadowBox.hs @@ -5,22 +5,12 @@ import Polyhedra import Geometry import qualified Data.IntMap as IM -crToBox :: Creature -> [[Point3]] -crToBox cr = map (map f . polyToTris) $ boxXYZ 8 8 15 - where - f = (+ V3 (x-4) (y-4) 1) - V2 x y = _crPos cr youBox' :: World -> [[Point3]] youBox' w = crToBox' $ _creatures w IM.! 0 - -youBox :: World -> [Point3] -youBox = concat . youBox' - crToBox' :: Creature -> [[Point3]] crToBox' cr = map (map f . polyToTris) $ boxXYZ 12 12 15 where f = (+ V3 (x-6) (y-6) 0) V2 x y = _crPos cr - youSil :: World -> [Point3] youSil = constructEdgesList . youBox' diff --git a/src/Dodge/Creature/Silhouette.hs b/src/Dodge/Creature/Silhouette.hs index c2101fe2c..d3da45331 100644 --- a/src/Dodge/Creature/Silhouette.hs +++ b/src/Dodge/Creature/Silhouette.hs @@ -14,13 +14,8 @@ creatureSilhouettes w = concatMap f . IM.elems $ _creatures w where f cr = _crSilhouette cr cr -crBox :: [Point3] -crBox = constructEdgesList . map (map f . polyToTris) $ boxXYZ 12 12 15 - where - f = (+ V3 (-6) (-6) 0) - basicCrSilhouette :: Creature -> [Point3] -basicCrSilhouette cr = map theTrans crBox +basicCrSilhouette cr = constructEdgesList . map (map f . polyToTris) $ boxXYZ 12 12 15 where - theTrans = (+ V3 x y 0) + f = (+ V3 (x-6) (y-6) 0) V2 x y = _crPos cr diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index edca86d8a..66ce6f094 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -50,7 +50,7 @@ wasdWithAiming w speed i cr isAiming = _posture (_crStance cr) == Aiming mouseDir = case w ^? creatures . ix i . crInv . ix (_crInvSel (_creatures w IM.! i)) . itAttachment of - Just (Just ItScope{_scopePos = p}) -> normalizeAngle $ argV + Just ItScope{_scopePos = p} -> normalizeAngle $ argV $ p +.+ 2 / _cameraZoom w *.* rotateV (_cameraRot w) (_mousePos w) _ -> normalizeAngle $ argV (_mousePos w) + _cameraRot w diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 21f617acb..1ba6774cd 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -33,6 +33,7 @@ import Geometry.Data import Polyhedra.Data import Sound.Data import qualified DoubleStack as DS +import Dodge.GameRoom import GHC.Generics import Control.Lens @@ -107,6 +108,7 @@ data World = World , _inventoryMode :: InventoryMode , _lClickHammer :: HammerPosition , _radDistortion :: [(Point2,Point2,Point2,Float)] + , _gameRooms :: [GameRoom] } data InventoryMode = TopInventory @@ -239,11 +241,12 @@ data Item , _itAmount :: Int , _itAimingSpeed :: Float , _itAimingRange :: Float - , _itZoom :: ItZoom + , _itZoom :: ItZoom + , _itAimZoom :: ItZoom , _itEquipPict :: Creature -> Int -> Picture , _itScroll :: Float -> Creature -> World -> World , _itIdentity :: ItemIdentity - , _itAttachment :: Maybe ItAttachment + , _itAttachment :: ItAttachment , _itID :: Maybe Int , _itEffect :: ItEffect , _itInvDisplay :: Item -> String @@ -292,6 +295,7 @@ data Item , _itAimingSpeed :: Float , _itAimingRange :: Float , _itZoom :: ItZoom + , _itAimZoom :: ItZoom , _itInvDisplay :: Item -> String , _itInvColor :: Color , _itHammer :: HammerPosition @@ -311,10 +315,11 @@ data Item , _itAimingSpeed :: Float , _itAimingRange :: Float , _itZoom :: ItZoom + , _itAimZoom :: ItZoom , _itEquipPict :: Creature -> Int -> Picture , _itIdentity :: ItemIdentity , _itID :: Maybe Int - , _itAttachment :: Maybe ItAttachment + , _itAttachment :: ItAttachment , _itInvDisplay :: Item -> String , _itInvColor :: Color , _itEffect :: ItEffect @@ -339,12 +344,9 @@ data ItEffect = NoItEffect ,_itEffectCounter :: Int } data ItZoom = ItZoom - {_itAimZoomMax :: Float - ,_itAimZoomMin :: Float - ,_itAimZoomFac :: Float - ,_itZoomMax :: Float - ,_itZoomMin :: Float - ,_itZoomFac :: Float + { _itZoomMax :: Float + , _itZoomMin :: Float + , _itZoomFac :: Float } data IntID a = IntID Int a {- Objects without ids. diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index b7e9deeb4..ac33edf00 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -77,13 +77,14 @@ defaultEquipment = Equipment , _itID = Nothing , _itAimingSpeed = 1 , _itAimingRange = 0 - , _itZoom = defaultItZoom + , _itZoom = defaultItZoom + , _itAimZoom = defaultItZoom , _itInvColor = yellow , _itInvDisplay = _itName , _itAimStance = LeaveHolstered } defaultItZoom :: ItZoom -defaultItZoom = ItZoom 20 0.2 1 20 0.2 1 +defaultItZoom = ItZoom 20 0.2 1 defaultConsumable :: Item defaultConsumable = Consumable { _itIdentity = Generic diff --git a/src/Dodge/Default/Weapon.hs b/src/Dodge/Default/Weapon.hs index fecfaa7ee..fd3360d27 100644 --- a/src/Dodge/Default/Weapon.hs +++ b/src/Dodge/Default/Weapon.hs @@ -3,6 +3,7 @@ module Dodge.Default.Weapon import Dodge.Data import Dodge.Item.Weapon.ExtraEffect import Dodge.Item.Weapon.InventoryDisplay +import Dodge.Item.Attachment.Data import Dodge.Item.Data import Picture defaultGun :: Item @@ -32,10 +33,11 @@ defaultGun = Weapon , _itMaxStack = 1 , _itAimingSpeed = 1 , _itAimingRange = 0 - , _itZoom = ItZoom 20 0.2 1 20 0.2 1 + , _itZoom = ItZoom 20 0.2 1 + , _itAimZoom = ItZoom 20 0.2 1 , _itEquipPict = \_ _ -> blank , _itScroll = \_ _ -> id - , _itAttachment = Nothing + , _itAttachment = NoItAttachment , _itID = Nothing , _itEffect = wpRecock , _itInvDisplay = basicWeaponDisplay diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index e481f1ae3..36efcc96b 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -82,6 +82,7 @@ defaultWorld = World , _foregroundDecorations = [] , _foregroundEdgeVerx = [] , _radDistortion = [] + , _gameRooms = [] } defaultDebugFlags :: DebugFlags defaultDebugFlags = DebugFlags diff --git a/src/Dodge/GameRoom.hs b/src/Dodge/GameRoom.hs new file mode 100644 index 000000000..e2645cc20 --- /dev/null +++ b/src/Dodge/GameRoom.hs @@ -0,0 +1,10 @@ +{- | GameRooms contain information about given positions in the world + -} +module Dodge.GameRoom + where +import Geometry + +data GameRoom = GameRoom + { _grViewpoints :: [Point2] + , _grBound :: [Point2] + } diff --git a/src/Dodge/Item/Attachment.hs b/src/Dodge/Item/Attachment.hs index ae75e64e3..edc714922 100644 --- a/src/Dodge/Item/Attachment.hs +++ b/src/Dodge/Item/Attachment.hs @@ -34,12 +34,12 @@ incCharMode :: Int -- ^ Inventory selection -> World -> World -incCharMode i = creatures . ix 0 . crInv . ix i . itAttachment . _Just %~ incCharMode' +incCharMode i = creatures . ix 0 . crInv . ix i . itAttachment %~ incCharMode' decCharMode :: Int -- ^ Inventory selection -> World -> World -decCharMode i = creatures . ix 0 . crInv . ix i . itAttachment . _Just %~ decCharMode' +decCharMode i = creatures . ix 0 . crInv . ix i . itAttachment %~ decCharMode' charFiringStrat :: [(Char, Creature -> World -> World)] -- ^ Different firing effects for different characters @@ -47,7 +47,7 @@ charFiringStrat -> World -> World charFiringStrat strats cr w = case w ^? creatures . ix cid . crInv - . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment . _Just . itCharMode of + . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment . itCharMode of Just (c :<| _) -> fromJust (Prelude.lookup c strats) cr w _ -> w where @@ -60,7 +60,7 @@ charFiringStratI -> World -> World charFiringStratI strats eff item cr w = case w ^? creatures . ix cid . crInv - . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment . _Just . itCharMode of + . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment . itCharMode of Just (c :<| _) -> fromJust (Prelude.lookup c strats) eff item cr w _ -> w where @@ -75,8 +75,8 @@ increaseFuse fuse itid w = w & creatures . ix 0 . crInv . ix itid %~ ( itScrollUp .~ decreaseFuse newTime ) . (itScrollDown .~ increaseFuse newTime ) - . ( itAttachment ?~ ItFuse newTime ) - . ( itZoom .~ defaultItZoom{_itAimZoomMax = zm, _itAimZoomMin = zm} ) + . ( itAttachment .~ ItFuse newTime ) + . ( itAimZoom .~ defaultItZoom{_itZoomMax = zm, _itZoomMin = zm} ) where newTime = min (fuse + 5) 90 zm = 50 / fromIntegral newTime @@ -89,8 +89,8 @@ decreaseFuse fuse itid w = w & creatures . ix 0 . crInv . ix itid %~ ( itScrollUp .~ decreaseFuse newTime ) . ( itScrollDown .~ increaseFuse newTime ) - . ( itAttachment ?~ ItFuse newTime ) - . ( itZoom .~ defaultItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm} ) + . ( itAttachment .~ ItFuse newTime ) + . ( itAimZoom .~ defaultItZoom {_itZoomMax = zm, _itZoomMin = zm} ) where newTime = max (fuse - 5) 20 zm = 50 / fromIntegral newTime diff --git a/src/Dodge/Item/Attachment/Data.hs b/src/Dodge/Item/Attachment/Data.hs index 1a1c42859..256f5b5a2 100644 --- a/src/Dodge/Item/Attachment/Data.hs +++ b/src/Dodge/Item/Attachment/Data.hs @@ -9,15 +9,16 @@ import qualified Data.Sequence as Seq data ItAttachment = ItScope - {_scopePos :: Point2 + {_scopePos :: Point2 -- ^ a camera offset ,_scopeZoomChange :: Int ,_scopeZoom :: Float - ,_scopeIsCamera :: Bool + ,_scopeIsCamera :: Bool -- ^ if the camera offset is also the center of vision } | ItFuse {_itFuseTime :: Int} | ItMode {_itMode :: Int} | ItCharMode {_itCharMode :: Seq.Seq Char } | ItTargetPos { _itTargetPos :: Point2 } | ItInt { _itInt :: Int } + | NoItAttachment makeLenses ''ItAttachment diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index d3cd2154d..ab0b53cab 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -24,10 +24,11 @@ import Dodge.Item.Weapon.Laser import Dodge.Item.Weapon.Shell import Dodge.Item.Weapon.Bullet import Dodge.Item.Weapon.AmmoParams +import Dodge.Item.Attachment.Data import Dodge.Default.Weapon import Dodge.Item.Weapon.Booster import Dodge.Item.Weapon.Grenade -import Dodge.Item.Attachment.Data +--import Dodge.Item.Attachment.Data import Dodge.Item.Attachment import Geometry import Geometry.Vector3D @@ -80,7 +81,7 @@ pistol = defaultGun , _itAimingRange = 0 , _itZoom = defaultItZoom , _itEquipPict = pictureWeaponOnAim pistolPic - , _itAttachment = Nothing + , _itAttachment = NoItAttachment , _itID = Nothing , _itEffect = wpRecock , _itInvDisplay = basicWeaponDisplay @@ -187,7 +188,7 @@ lasGun = defaultAutoGun , _itAimingSpeed = 0.4 , _itAimingRange = 1 , _itEquipPict = pictureWeaponOnAim lasGunPic - , _itAttachment = Just $ ItCharMode $ Seq.fromList "/VZ" + , _itAttachment = ItCharMode $ Seq.fromList "/VZ" , _itScroll = scrollCharMode , _itInvDisplay = basicWeaponDisplay } @@ -253,7 +254,7 @@ tractorGun = defaultAutoGun removeItAttachment :: Int -> Int -> World -> World -removeItAttachment i _ w = w & creatures . ix i . crInv . ix itRef . itAttachment .~ Nothing +removeItAttachment i _ w = w & creatures . ix i . crInv . ix itRef . itAttachment .~ NoItAttachment where cr = _creatures w IM.! i itRef = _crInvSel cr @@ -278,7 +279,7 @@ remoteLauncher = defaultGun , _itAimingSpeed = 0.2 , _itAimingRange = 0.5 , _itEquipPict = pictureWeaponOnAim $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) - , _itAttachment = Just $ ItScope (V2 0 0) 0 1 True + , _itAttachment = ItScope (V2 0 0) 0 1 True } hvAutoGun :: Item hvAutoGun = defaultAutoGun @@ -470,7 +471,8 @@ multGun = defaultGun , _itFloorPict = onLayer FlItLayer multGunPic , _itAimingSpeed = 0.4 , _itAimingRange = 1 - , _itZoom = defaultItZoom {_itAimZoomFac = 1.5} + , _itZoom = defaultItZoom + , _itAimZoom = defaultItZoom {_itZoomFac = 1.5} , _itEquipPict = pictureWeaponOnAim multGunPic , _itAimStance = TwoHandTwist , _wpAmmo = basicBullet @@ -514,10 +516,11 @@ longGun = defaultGun , _itFloorPict = onLayer FlItLayer longGunPic , _itAimingSpeed = 0.2 , _itAimingRange = 1 - , _itZoom = defaultItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5} + , _itZoom = defaultItZoom + , _itAimZoom = defaultItZoom {_itZoomMax = 0.5, _itZoomMin = 0.5} , _itEquipPict = pictureWeaponOnAim longGunPic , _itScroll = zoomLongGun - , _itAttachment = Just $ ItScope (V2 0 0) 0 1 False + , _itAttachment = ItScope (V2 0 0) 0 1 False , _itEffect = itemLaserScopeEffect , _wpAmmo = hvBullet , _itAimStance = TwoHandTwist @@ -533,10 +536,10 @@ zoomLongGun x cr startZoomInLongGun :: Int -> World -> World startZoomInLongGun _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange %~ \x -> max 5 (x + 5) + . itAttachment . scopeZoomChange %~ \x -> max 5 (x + 5) startZoomOutLongGun :: Int -> World -> World startZoomOutLongGun _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange %~ \x -> min (-5) (x-5) + . itAttachment . scopeZoomChange %~ \x -> min (-5) (x-5) poisonSprayer :: Item poisonSprayer = defaultAutoGun { _itName = "POISON" @@ -586,9 +589,10 @@ flamer = defaultAutoGun , _itFloorPict = onLayer FlItLayer flamerPic , _itAimingSpeed = 0.5 , _itAimingRange = 0 - , _itZoom = defaultItZoom {_itAimZoomMax = 5, _itAimZoomMin = 1.5} + , _itZoom = defaultItZoom + , _itAimZoom = defaultItZoom {_itZoomMax = 5, _itZoomMin = 1.5} , _itEquipPict = pictureWeaponOnAim flamerPic - , _itAttachment = Nothing + , _itAttachment = NoItAttachment } flamerPic :: Picture flamerPic = color yellow $ pictures @@ -709,7 +713,7 @@ pointToItem (OnFloor flid) = floorItems . ix flid . flIt retireRemoteRocket :: Int -> Int -> Int -> World -> World retireRemoteRocket itid 0 pjid w = - set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) (V2 0 0) + set (pointToItem (_itemPositions w IM.! itid) . itAttachment . scopePos) (V2 0 0) $ set (pointToItem (_itemPositions w IM.! itid) . itUse) (const fireRemoteLauncher) (w & projectiles %~ IM.delete pjid) retireRemoteRocket itid t pjid w = setScope w @@ -718,13 +722,13 @@ retireRemoteRocket itid t pjid w = setScope w setScope w' = case _itemPositions w' IM.! itid of InInv cid invid -> w' & creatures . ix cid . crInv . ix invid . itAttachment - . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) + . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) _ -> w' pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos retireRemoteBomb :: Int -> Int -> Int -> World -> World retireRemoteBomb itid 0 pjid w = w & pointToItem (_itemPositions w IM.! itid) %~ - ( (itAttachment . _Just . scopePos .~ V2 0 0) + ( (itAttachment . scopePos .~ V2 0 0) . (itZoom .~ defaultItZoom) . (itUse .~ const throwRemoteBomb) ) @@ -735,7 +739,7 @@ retireRemoteBomb itid t pjid w = setScope w setScope w' = case _itemPositions w' IM.! itid of InInv cid invid -> w' & creatures . ix cid . crInv . ix invid . itAttachment - . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) + . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) _ -> w' pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos @@ -782,16 +786,16 @@ setRemoteScope :: Int -> Projectile -> World -> World setRemoteScope itid pj w' = case w' ^? itemPositions . ix itid of Just (InInv cid' invid ) -> w' & creatures . ix cid' . crInv . ix invid . itAttachment - . _Just . scopePos .~ (_pjPos pj -.- _crPos (_creatures w' IM.! cid')) + . scopePos .~ (_pjPos pj -.- _crPos (_creatures w' IM.! cid')) _ -> w' setRemoteBombScope :: Int -> Projectile -> World -> World setRemoteBombScope itid pj w' = case _itemPositions w' IM.! itid of InInv cid invid -> w' & creatures . ix cid . crInv . ix invid . itAttachment - . _Just . scopePos .~ (_pjPos pj -.- _crPos (_creatures w' IM.! cid)) - & creatures . ix cid . crInv . ix invid . itZoom - .~ (defaultItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5}) + . scopePos .~ (_pjPos pj -.- _crPos (_creatures w' IM.! cid)) + & creatures . ix cid . crInv . ix invid . itAimZoom + .~ (defaultItZoom {_itZoomMax = 0.5, _itZoomMin = 0.5}) _ -> w' grenade :: Item @@ -809,12 +813,13 @@ grenade = Throwable ] , _itAimingSpeed = 1 , _itAimingRange = 0 - , _itZoom = defaultItZoom {_itAimZoomMax = f fuseTime, _itAimZoomMin = f fuseTime} + , _itZoom = defaultItZoom + , _itAimZoom = defaultItZoom {_itZoomMax = f fuseTime, _itZoomMin = f fuseTime} , _itEquipPict = pictureWeaponOnAim $ grenadePic fuseTime , _itID = Nothing , _itUseRate = 25 , _itUseTime = 0 - , _itAttachment = Just $ ItFuse fuseTime + , _itAttachment = ItFuse fuseTime , _itInvColor = white , _itInvDisplay = basicWeaponDisplay , _itEffect = wpRecock @@ -860,7 +865,7 @@ remoteBomb = defaultThrowable , _itUseModifiers = [ hammerCheckI ] - , _itAttachment = Just $ ItScope (V2 0 0) 0 1 True + , _itAttachment = ItScope (V2 0 0) 0 1 True , _itEquipPict = pictureWeaponOnAim remoteBombUnarmedPic } @@ -1062,7 +1067,8 @@ radar = defaultGun , _itAmount = 1 , _itMaxStack = 1 , _itAimingRange = 1 - , _itZoom = defaultItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + , _itZoom = defaultItZoom { _itZoomMax = 1} + , _itAimZoom = defaultItZoom { _itZoomMax = 1} , _itEquipPict = pictureWeaponOnAim $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) } {- | @@ -1087,7 +1093,8 @@ sonar = defaultGun , _itAmount = 1 , _itMaxStack = 1 , _itAimingRange = 1 - , _itZoom = defaultItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + , _itZoom = defaultItZoom {_itZoomMax = 1} + , _itAimZoom = defaultItZoom {_itZoomMax = 1} , _itEquipPict = pictureWeaponOnAim $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) } {- | @@ -1104,7 +1111,8 @@ autoSonar = defaultEquipment , _itID = Nothing , _itAimingSpeed = 1 , _itAimingRange = 0 - , _itZoom = defaultItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + , _itZoom = defaultItZoom {_itZoomMax = 1} + , _itAimZoom = defaultItZoom {_itZoomMax = 1} } {- | Automatically sends out pulses that display walls. -} @@ -1120,7 +1128,8 @@ autoRadar = defaultEquipment , _itID = Nothing , _itAimingSpeed = 1 , _itAimingRange = 0 - , _itZoom = defaultItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + , _itZoom = defaultItZoom {_itZoomMax = 1} + , _itAimZoom = defaultItZoom {_itZoomMax = 1} } {- | Creates a creature next to the creature using the item. -} diff --git a/src/Dodge/Item/Weapon/AutoGun.hs b/src/Dodge/Item/Weapon/AutoGun.hs index 88f97cbac..0b28cacec 100644 --- a/src/Dodge/Item/Weapon/AutoGun.hs +++ b/src/Dodge/Item/Weapon/AutoGun.hs @@ -48,10 +48,11 @@ autoGun = defaultAutoGun , _itFloorPict = onLayer FlItLayer autoGunPic , _itAimingSpeed = 0.4 , _itAimingRange = 1 - , _itZoom = defaultItZoom {_itAimZoomFac = 1.5} + , _itZoom = defaultItZoom + , _itAimZoom = defaultItZoom {_itZoomFac = 1.5} , _itEquipPict = pictureWeaponOnAim autoGunPic , _itEffect = wpRecock - , _itAttachment = Just $ ItCharMode $ Seq.fromList "MS" + , _itAttachment = ItCharMode $ Seq.fromList "MS" , _itScroll = scrollCharMode , _itInvDisplay = basicWeaponDisplay , _wpAmmo = basicBullet diff --git a/src/Dodge/Item/Weapon/Bezier.hs b/src/Dodge/Item/Weapon/Bezier.hs index bb58e3668..74be75cb8 100644 --- a/src/Dodge/Item/Weapon/Bezier.hs +++ b/src/Dodge/Item/Weapon/Bezier.hs @@ -8,6 +8,7 @@ import Dodge.Item.Draw import Dodge.Item.Weapon.Targeting import Dodge.Item.Weapon.TriggerType import Dodge.Item.Weapon.ExtraEffect +import Dodge.Item.Attachment.Data import Dodge.Default import Dodge.Particle.Bullet.Spawn import Dodge.Particle.Bullet.HitEffect @@ -35,7 +36,7 @@ bezierGun = defaultGun ] , _itFloorPict = onLayer FlItLayer bezierGunPic , _itEquipPict = pictureWeaponOnAim bezierGunPic - , _itAttachment = Nothing + , _itAttachment = NoItAttachment , _itScroll = removeItTarget 0 , _itHammer = HammerUp , _itEffect = rbSetTarget diff --git a/src/Dodge/Item/Weapon/Booster.hs b/src/Dodge/Item/Weapon/Booster.hs index d13b5a520..d4c3249f5 100644 --- a/src/Dodge/Item/Weapon/Booster.hs +++ b/src/Dodge/Item/Weapon/Booster.hs @@ -41,14 +41,14 @@ boostSelfL x cr invid w = case boostPoint x cr w of cpos = _crPos cr r = _crRad cr pid = fromMaybe (IM.newKey $ _projectiles w) - (cr ^? crInv . ix invid . itAttachment . _Just . itInt) + (cr ^? crInv . ix invid . itAttachment . itInt) crEff p ammoEff = addBoostShockwave pid p (r *.* normalizeV (p -.- cpos)) w & creatures . ix cid %~ (crPos .~ p) . (crInv . ix invid %~ ammoEff . (itEffect . itEffectCounter .~ 1) - . (itAttachment ?~ ItInt pid) + . (itAttachment .~ ItInt pid) ) boostSelf @@ -120,7 +120,7 @@ resetAttachmentID :: ItEffect resetAttachmentID = ItInvEffect f 0 where f iteff cr invid w - | _itEffectCounter iteff < 0 = w & pointToIt . itAttachment .~ Nothing + | _itEffectCounter iteff < 0 = w & pointToIt . itAttachment .~ NoItAttachment | otherwise = w & pointToIt . itEffect . itEffectCounter -~ 1 where pointToIt = creatures . ix (_crID cr) . crInv . ix invid diff --git a/src/Dodge/Item/Weapon/ExtraEffect.hs b/src/Dodge/Item/Weapon/ExtraEffect.hs index c9ba41aeb..421f6ea24 100644 --- a/src/Dodge/Item/Weapon/ExtraEffect.hs +++ b/src/Dodge/Item/Weapon/ExtraEffect.hs @@ -9,7 +9,7 @@ import Dodge.Base import Dodge.Item.Data import Dodge.Item.Weapon.Decoration import Dodge.Item.Weapon.UseEffect ---import Dodge.Item.Attachment.Data +import Dodge.Item.Attachment.Data import Dodge.WorldEvent.Flash import Dodge.WorldEvent.ThingsHit import Dodge.Picture.Layer @@ -49,7 +49,7 @@ bezierRecock = ItInvEffect f _ cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i fOnIt it = case _itHammer it of HammerDown -> it & itHammer .~ HammerUp - _ -> it & itAttachment .~ Nothing + _ -> it & itAttachment .~ NoItAttachment {- | Creates a laser scope and recocks the weapon. -} diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index f4b930d1b..7bb737248 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -15,7 +15,6 @@ import Picture import Geometry import Control.Lens -import Data.Maybe (fromJust) import qualified Data.IntMap.Strict as IM --import System.Random @@ -90,7 +89,7 @@ throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w dir = argV v setWp :: World -> World setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 - fuseTime = _itFuseTime $ fromJust $ _itAttachment $ _crInv cr IM.! j + fuseTime = _itFuseTime $ _itAttachment $ _crInv cr IM.! j throwArmReset :: Int -> ItEffect throwArmReset x = ItInvEffect {_itInvEffect = f ,_itEffectCounter = x } diff --git a/src/Dodge/Item/Weapon/InventoryDisplay.hs b/src/Dodge/Item/Weapon/InventoryDisplay.hs index acdfeb934..3ea0b4369 100644 --- a/src/Dodge/Item/Weapon/InventoryDisplay.hs +++ b/src/Dodge/Item/Weapon/InventoryDisplay.hs @@ -13,7 +13,7 @@ import Control.Lens --import Control.Monad {- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -} basicWeaponDisplay :: Item -> String -basicWeaponDisplay it = case it ^? itAttachment . _Just of +basicWeaponDisplay it = case it ^? itAttachment of Just ItCharMode {_itCharMode = (c :<| _)} -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) ++ [' ',c] Just ItMode {_itMode = i} -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) ++ show i _ -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) diff --git a/src/Dodge/Item/Weapon/Laser.hs b/src/Dodge/Item/Weapon/Laser.hs index 987686dc0..79ac2db7b 100644 --- a/src/Dodge/Item/Weapon/Laser.hs +++ b/src/Dodge/Item/Weapon/Laser.hs @@ -31,7 +31,7 @@ aLaser cr w = over particles (makeLaserAt phaseV pos dir : ) pos = _crPos cr +.+ ((_crRad cr +3) *.* unitVectorAtAngle dir) dir = _crDir cr phaseV = charToPhaseV - $ fromMaybe '/' $ Seq.lookup 0 =<< cr ^? crInv . ix j . itAttachment . _Just . itCharMode + $ fromMaybe '/' $ Seq.lookup 0 =<< cr ^? crInv . ix j . itAttachment . itCharMode j = _crInvSel cr charToPhaseV :: Fractional p => Char -> p diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index ce8ac15b1..2166b3654 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -272,12 +272,12 @@ withTempLight time rad col eff item cr = eff item cr . over tempLightSources (theTLS :) where theTLS = defaultTLS - { _tlsPos = V3 x y 20 + { _tlsPos = V3 x y 10 , _tlsRad=rad , _tlsIntensity = col , _tlsTime = time } - V2 x y = _crPos cr +.+ 5 *.* unitVectorAtAngle (_crDir cr) + V2 x y = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr) withMuzFlareI :: ChainEffect withMuzFlareI f it cr w = tempLightForAt 3 pos2 -- . muzzleFlashAt pos2 @@ -346,7 +346,7 @@ torqueAfterI torque feff item cr w cid = _crID cr (rot, g) = randomR (-torque,torque) $ _randGen w rotateScope = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopePos %~ rotateV rot + . itAttachment . scopePos %~ rotateV rot spreadNumI :: ChainEffect spreadNumI eff item cr w = foldr f w dirs where diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 57272e02c..8fa5c6a93 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -6,6 +6,7 @@ import Dodge.LevelGen.StaticWalls --import Dodge.LevelGen.Data import Dodge.Base import Dodge.Base.Zone +import Dodge.GameRoom --import Dodge.RandomHelp import Dodge.Graph import Dodge.Layout.Tree.Polymorphic (applyToRoot) @@ -41,6 +42,7 @@ generateLevelFromRoomList gr w = updateWallZoning -- . addRoomLinkDecorations rs $ w { _walls = wallsFromRooms rs , _floorTiles = floorsFromRooms rs + , _gameRooms = gameRoomsFromRooms rs } where plmnts = concatMap _rmPS rs @@ -123,6 +125,15 @@ wallsFromRooms = where f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i} +gameRoomsFromRooms :: [Room] -> [GameRoom] +gameRoomsFromRooms = map f + where + f rm = GameRoom + { _grViewpoints = (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) + ++ map fst (_rmLinks rm) + , _grBound = expandPolyByFixed 100 $ convexHullSafe $ concat $ _rmBound rm ++ _rmPolys rm + } + floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms = concatMap (concatMap tToRender . _rmFloor) diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 1242e0087..a74b2e5a0 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -133,14 +133,21 @@ cutPoly qs wls = ps = orderPolygon qs rs = orderPolygon $ nubOrd $ zs ++ qs -- | Given a value and a poly, pushes the poly points out from the center by the --- value amount. +-- factor amount. expandPolyBy :: Float -> [Point2] -> [Point2] expandPolyBy x ps = map f ps where --cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps cp = centroid ps f p = p +.+ x *.* (p -.- cp) - --f p = p +.+ x *.* normalizeV (p -.- cp) +-- | Given a value and a poly, pushes the poly points out from the center by the +-- fixed amount. +expandPolyByFixed :: Float -> [Point2] -> [Point2] +expandPolyByFixed x ps = map f ps + where + --cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps + cp = centroid ps + f p = p +.+ x *.* safeNormalizeV (p -.- cp) -- | Given a polygon expressed as a list of points and a collection of walls, -- returns: -- fst: points of the polygon's intersection with walls diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index a7d7e5b15..b487f9005 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -8,7 +8,7 @@ import Dodge.Data import Dodge.Config.Data import Dodge.Base.Window import Dodge.Render.Picture -import Dodge.Creature.ShadowBox +--import Dodge.Creature.ShadowBox import Dodge.Creature.Silhouette import Geometry import Render diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index f9b65da28..56c9535be 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -224,9 +224,9 @@ lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTL where getLS ls | dist campos (fst2 $ _lsPos ls) > 1000 = Nothing - | otherwise = Just ( _lsPos ls, (_lsRad ls)^2 , _lsIntensity ls) + | otherwise = Just ( _lsPos ls, _lsRad ls^(2::Int) , _lsIntensity ls) getTLS ls | dist campos (fst2 $ _tlsPos ls) > 1000 = Nothing - | otherwise = Just ( _tlsPos ls, (_tlsRad ls)^2, _tlsIntensity ls) + | otherwise = Just ( _tlsPos ls, _tlsRad ls^(2::Int), _tlsIntensity ls) campos = _cameraCenter w fst2 (V3 a b _) = V2 a b diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 93b009a24..1794dab2d 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -14,6 +14,8 @@ import Dodge.Base.Collide import Dodge.Config.KeyConfig import Dodge.Item.Attachment.Data import Geometry +import Geometry.ConvexPoly +import Dodge.GameRoom import qualified Data.List.NonEmpty as NEL import Control.Lens @@ -24,14 +26,16 @@ import qualified Data.IntMap.Strict as IM import qualified SDL import Data.Monoid import Data.Semigroup +import qualified Control.Foldl as L {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; update where your avatar's view is from. -} updateCamera :: World -> World updateCamera = rotCam . moveCamera . updateScopeZoom {- Updte the center of the screen camera center and where your avatar's view is from in world. -} moveCamera :: World -> World -moveCamera w = w & cameraCenter .~ idealPos - & cameraViewFrom .~ sightFrom +moveCamera w = w + & cameraCenter .~ idealPos + & cameraViewFrom .~ sightFrom where aimRangeFactor | _cameraZoom w == 0 = 0 @@ -40,17 +44,13 @@ moveCamera w = w & cameraCenter .~ idealPos | SDL.ButtonRight `S.member` _mouseButtons w = 1 | otherwise = 0 ypos = _crPos $ you w - --idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) - --currentOffset = currentPos -.- camCenter - idealPos = camCenter +.+ rotateV (_cameraRot w) - (aimRangeFactor * aimingMult *.* _mousePos w) - --currentPos = _cameraCenter w - camCenter = ypos +.+ scope - isCam :: Bool - isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera - scope = fromMaybe (V2 0 0) $ yourItem w ^? itAttachment . _Just . scopePos + idealPos = camCenter + +.+ rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) + camCenter = ypos +.+ scopeOffset + scopeOffset = fromMaybe (V2 0 0) $ yourItem w ^? itAttachment . scopePos sightFrom - | isCam = camCenter + | fromMaybe False $ yourItem w ^? itAttachment . scopeIsCamera + = camCenter | otherwise = ypos updateScopeZoom :: World -> World @@ -59,49 +59,50 @@ updateScopeZoom w Just x | x > 9 -> zoomInLongGun $ zoomInLongGun $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange -~ 2 + . itAttachment . scopeZoomChange -~ 2 | x > 0 -> zoomInLongGun $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange -~ 1 + . itAttachment . scopeZoomChange -~ 1 | x < -9 -> zoomOutLongGun $ zoomOutLongGun $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange +~ 2 + . itAttachment . scopeZoomChange +~ 2 | x < 0 -> zoomOutLongGun $ zoomOutLongGun $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange +~ 1 + . itAttachment . scopeZoomChange +~ 1 | otherwise -> w _ -> w | otherwise = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just %~ updateScope - where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopeZoomChange - updateScope (ItScope _ _ _ bl) = ItScope (V2 0 0) 0 1 bl - updateScope otherAtt = otherAtt + . itAttachment %~ updateScope + where + scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . scopeZoomChange + updateScope (ItScope _ _ _ bl) = ItScope (V2 0 0) 0 1 bl + updateScope otherAtt = otherAtt zoomSpeed :: Float zoomSpeed = 39/40 zoomInLongGun :: World -> World zoomInLongGun w - | currentZoom < 8 = over (wpPointer . itAttachment . _Just . scopePos) + | currentZoom < 8 = over (wpPointer . itAttachment . scopePos) (\p -> p +.+ (4-(4*zoomSpeed)) / currentZoom *.* mousep) - $ over (wpPointer . itAttachment . _Just . scopeZoom) (/ zoomSpeed) + $ over (wpPointer . itAttachment . scopeZoom) (/ zoomSpeed) w | otherwise = w where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0) - Just currentZoom = wp ^? itAttachment . _Just . scopeZoom + Just currentZoom = wp ^? itAttachment . scopeZoom mousep = rotateV (_cameraRot w) $ _mousePos w zoomOutLongGun :: World -> World zoomOutLongGun w - | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just . scopeZoom) (* zoomSpeed) w + | currentZoom > 0.5 = over (wpPointer . itAttachment . scopeZoom) (* zoomSpeed) w | otherwise = w where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0) - Just currentZoom = wp ^? itAttachment . _Just . scopeZoom + Just currentZoom = wp ^? itAttachment . scopeZoom --currentCursorDisplacement = fromJust $ _itAttachment wp rotCam :: World -> World @@ -115,13 +116,13 @@ rotateCameraL w | rotateCameraPlusKey (_keyConfig w) `S.member` _keys w = w & cameraRot +~ 0.015 & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopePos %~ rotateV 0.015 + . itAttachment . scopePos %~ rotateV 0.015 | otherwise = w rotateCameraR :: World -> World rotateCameraR w | rotateCameraMinusKey (_keyConfig w) `S.member` _keys w = w & cameraRot -~ 0.015 & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment . _Just . scopePos %~ rotateV (-0.015) + . itAttachment . scopePos %~ rotateV (-0.015) | otherwise = w zoomCamIn :: World -> World zoomCamIn w | zoomInKey (_keyConfig w) `S.member` _keys w @@ -132,38 +133,64 @@ zoomCamOut w | zoomOutKey (_keyConfig w) `S.member` _keys w = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01} | otherwise = w -{- -Automatically sets the zoom of the camera according to the surrounding walls. - -} +zoomFromItem + :: ItZoom + -> Float -- ^ Furthest viewable distance + -> Float +zoomFromItem ItZoom {_itZoomMax = zMax, _itZoomMin = zMin, _itZoomFac = zFac} + = min zMax . max zMin . (zFac *) +zoomNoItem + :: Float -- ^ Furthest viewable distance + -> Float +zoomNoItem = min 20 . max 0.2 +{- Automatically sets the zoom of the camera according to the surrounding walls. -} autoZoomCam :: World -> World autoZoomCam w = over cameraZoom changeZoom w where camPos = _cameraViewFrom w - wallZoom = farWallDist camPos w - idealZoom | SDL.ButtonRight `S.member` _mouseButtons w - = scZoom * - min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax) - ( max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin) - (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac)) - ) - | otherwise - = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax) - $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin)) - (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac)) + wallZoom = farWallDist' camPos w + idealZoom + | SDL.ButtonRight `S.member` _mouseButtons w + = theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? itAimZoom) wallZoom + | otherwise + = maybe zoomNoItem zoomFromItem (yourItem w ^? itZoom) wallZoom changeZoom curZoom | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed - | curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed + | curZoom < idealZoom - 0.01 = ((zoomInSpeed -1)*curZoom + idealZoom) / zoomInSpeed | otherwise = idealZoom -- these speeds are inverted, larger means slower zoomInSpeed = 25 zoomOutSpeed = 15 - scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom + theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom +farWallDist' :: Point2 -> World -> Float +farWallDist' p w = (winFac /) $ fromMaybe 800 $ L.fold L.maximum vdists + where + hw = halfWidth w + hh = halfHeight w + winFac = min hw hh + vdists = map (flip (collideDirectionIndirect 800 p) wos) + vps + vps = concatMap _grViewpoints grs + grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) + wos = wallsOnScreen w + +-- | Find the furthest viewable distance from a given point in the world farWallDist :: Point2 -> World -> Float --{-# INLINE farWallDist #-} -farWallDist cpos w = getMin . uncurry (<>) $ bimap (toScale hw) (toScale hh) $ sconcat $ NEL.map distsMaybeTo viewTestValues +farWallDist cpos w + = getMin + . uncurry (<>) + $ bimap (toScale hw) (toScale hh) + $ sconcat + $ NEL.map distsMaybeTo viewTestValues where + wos = wallsOnScreen w + camRot = _cameraRot w + hw = halfWidth w + hh = halfHeight w + toScale x = Min . (x /) . (+ 50) . maybe maxViewDistance getMax . getAp distsMaybeTo x = (valueAtWidth x,valueAtHeight x) valueAtHeight h = cpiv (cpos +.+ x) <> cpiv (cpos -.- x) where @@ -177,17 +204,9 @@ farWallDist cpos w = getMin . uncurry (<>) $ bimap (toScale hw) (toScale hh) $ s cpih p = Ap $ Max . verSize <$> collidePointIndirect cpos p wos verSize = abs . dotV rh . (-.- cpos) rh = rotateV camRot (V2 0 1) - wos = wallsOnScreen w - camRot = _cameraRot w - hw = halfWidth w - hh = halfHeight w - toScale x = Min . (x /) . (+ 50) . maybe maxViewDistance getMax . getAp viewTestValues :: NEL.NonEmpty Float viewTestValues = NEL.fromList [-maxViewDistance,negate $ 0.75*maxViewDistance..maxViewDistance] maxViewDistance :: Float maxViewDistance = 800 - ---dirRays :: Float -> [Point2] ---dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0) diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 493b4d0e3..67ed4f0b4 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -91,18 +91,18 @@ moveFlame moveFlame rotd w pt | time <= 0 = (smokeGen w, Nothing) | otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of - ((_,E3x1 _):_) -> (soundAndGlare damcrs , mvPt') + ((_,E3x1 _):_) -> (doSound damcrs , mvPt') (thing@(p,E3x2 wl):_) -> (fst $ hiteff [thing] damcrs , rfl wl p) - _ -> (glare $ soundAndGlare damcrs , mvPt) + _ -> (glare $ doSound damcrs , mvPt) where time = _btTimer' pt - soundAndGlare = soundFrom Flame fireSound 2 500 -- . over worldEvents ((.) $ flameGlareAt ep) + doSound = soundFrom Flame fireSound 2 500 -- . over worldEvents ((.) $ flameGlareAt ep) glare | time `mod` 5 == 0 = tempLightSources %~ (theTLS :) | otherwise = id theTLS = defaultTLS - { _tlsPos = V3 x y 15 + { _tlsPos = V3 x y 10 , _tlsRad = 70 , _tlsIntensity = V3 0.5 0 0 } diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs index 950f7b378..4944f6597 100644 --- a/src/FoldableHelp.hs +++ b/src/FoldableHelp.hs @@ -2,14 +2,18 @@ module FoldableHelp ( safeMinimumOn , safeMinimumOnMaybe + , safeMinimumOnMaybeF + , safeMinimumOnMaybeL + , safeMinMaybeL , module Data.Foldable ) where import Data.Foldable +import qualified Control.Foldl as L -- TODO check up whether and how it is necessary to specialise this -- | A version of 'minimum' where the comparison is done on some extracted value. --- Returns Nothing if the list is empty. Only calls the function once per element (not true). +-- Returns Nothing if the list is empty. -- -- > safeMinimumOn id [] == Nothing -- > safeMinimumOn length ["test","extra","a"] == Just "a" @@ -21,6 +25,34 @@ safeMinimumOn f = foldl' g Nothing | f x < f y = Just x | otherwise = Just y g Nothing y = Just y +safeMinimumOnMaybeF :: (Ord b) => (a -> Maybe b) -> [a] -> Maybe a +safeMinimumOnMaybeF f = L.fold $ L.Fold step initial extract + where + initial = Nothing + step Nothing x = (x ,) <$> f x + step (Just (a,x)) b = case f b of + Just y | y < x -> Just (b,y) + _ -> Just (a,x) + extract = fmap fst +safeMinMaybeL :: (Ord b) => (a -> Maybe b) -> L.Fold a (Maybe b) +safeMinMaybeL f = L.Fold step initial id + where + initial = Nothing + step Nothing x = f x + step (Just x) b = case f b of + Just y | y < x -> Just y + _ -> Just x + +safeMinimumOnMaybeL :: (Ord b) => (a -> Maybe b) -> L.Fold a (Maybe a) +safeMinimumOnMaybeL f = L.Fold step initial extract + where + initial = Nothing + step Nothing x = (x ,) <$> f x + step (Just (a,x)) b = case f b of + Just y | y < x -> Just (b,y) + _ -> Just (a,x) + extract = fmap fst + safeMinimumOnMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> Maybe a safeMinimumOnMaybe f ys = fst <$> go Nothing ys where @@ -29,6 +61,8 @@ safeMinimumOnMaybe f ys = fst <$> go Nothing ys Just v | v < cmin -> go (Just (x,v)) xs _ -> go (Just (y,cmin)) xs go m _ = m + + --{- | Partial. -} --minimumOn :: Ord b => (a -> b) -> [a] -> a --minimumOn f [] = error "tried to take minimumOn of empty list" diff --git a/src/FoldlHelp.hs b/src/FoldlHelp.hs new file mode 100644 index 000000000..6cb477ea8 --- /dev/null +++ b/src/FoldlHelp.hs @@ -0,0 +1,30 @@ +module FoldlHelp + ( minimumOn + , premapMaybe + , module Control.Foldl + ) + where +import Control.Foldl + +data Maybe' a = Just' !a | Nothing' +data Pair a b = !a :!: !b + +minimumOn :: Ord b => (a -> b) -> Fold a (Maybe a) +minimumOn f = Fold step Nothing' extract + where + extract Nothing' = Nothing + extract (Just' (a :!: _)) = Just a + step Nothing' b = Just' (b :!: f b) + step (Just' (a :!: x)) b + | y < x = Just' (b :!: y) + | otherwise = Just' (a :!: x) + where + y = f b + +premapMaybe :: (a -> Maybe b) -> Fold b r -> Fold a r +{-# INLINABLE premapMaybe #-} +premapMaybe f (Fold step initial extract) = Fold step' initial extract + where + step' x a = case f a of + Nothing -> x + Just s -> step x s diff --git a/src/Geometry.hs b/src/Geometry.hs index 6209e4f0b..925ab028b 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -128,15 +128,20 @@ addPointPolygon p ps | pointInOrOnPolygon p ps = ps | otherwise = orderPolygon $ p : ps -- | Creates the convex hull of a set of points. +-- Need to verify whether or not this is ordered convexHull :: [Point2] -> [Point2] convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs) convexHull _ = error "Tried to create the convex hull of two or fewer points" +-- | Creates the convex hull of a set of points. +-- Need to verify whether or not this is ordered +convexHullSafe :: [Point2] -> [Point2] +convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs) +convexHullSafe _ = [] grahamScan :: [Point2] -> [Point2] grahamScan = foldr push [] where push point stack = grahamEliminate (point:stack) - -- | Remove second element if top three elements are not counterclockwise. -- Repeat if necessary. See -- https://codereview.stackexchange.com/questions/206019/graham-scan-algorithm-in-haskell diff --git a/src/Geometry/ConvexPoly.hs b/src/Geometry/ConvexPoly.hs index 14e947281..62c887227 100644 --- a/src/Geometry/ConvexPoly.hs +++ b/src/Geometry/ConvexPoly.hs @@ -8,6 +8,7 @@ module Geometry.ConvexPoly , centroid , pointsToPoly , convexPolysOverlap + , pointInPolyPoints ) where import Geometry.Data import Geometry.Vector