diff --git a/src/Dodge/Base/WinScale.hs b/src/Dodge/Base/WinScale.hs index 671ef5632..886021d80 100644 --- a/src/Dodge/Base/WinScale.hs +++ b/src/Dodge/Base/WinScale.hs @@ -1,5 +1,6 @@ module Dodge.Base.WinScale where -import Dodge.Config.Data + +import Dodge.Data.Config import Geometry import Picture @@ -8,4 +9,4 @@ winScale :: Configuration -> Picture -> Picture winScale cfig = scale (2 / _windowX cfig) (2 / _windowY cfig) doWindowScale :: Configuration -> Point2 -> Point2 -doWindowScale cfig (V2 x y) = V2 ( x * 2 / _windowX cfig) ( y * 2 / _windowY cfig) +doWindowScale cfig (V2 x y) = V2 (x * 2 / _windowX cfig) (y * 2 / _windowY cfig) diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index 983495f57..01458ae26 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -40,7 +40,7 @@ splitBeamCombine (p,(a,b,_),(x,y,_)) teslaBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)) -> World -> World teslaBeamCombine (p,(a,b,bm),(x,y,_)) w - = w' & pointToItem (_itemPositions (_cWorld w) IM.! itid) . itParams . subParams ?~ ip + = w' & pointerToItem (_itemPositions (_cWorld w) IM.! itid) . itParams . subParams ?~ ip where itid = fromJust $ _bmOrigin bm dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)) diff --git a/src/Dodge/Bullet.hs b/src/Dodge/Bullet.hs index 784f39583..a31a14af2 100644 --- a/src/Dodge/Bullet.hs +++ b/src/Dodge/Bullet.hs @@ -1,40 +1,70 @@ -module Dodge.Bullet - ( updateBullet - , useAmmoParams - ) where -import Dodge.MagnetBuBu -import qualified ListHelp as List -import Dodge.EnergyBall +module Dodge.Bullet ( + updateBullet, + useAmmoParams, +) where + +import Data.Maybe +import Dodge.Base.Coordinate +import Dodge.Creature.HandPos import Dodge.Creature.Test import Dodge.Data -import Dodge.Creature.HandPos -import Dodge.Base.Coordinate +import Dodge.EnergyBall +import Dodge.MagnetBuBu +import Dodge.Movement.Turn import Dodge.WorldEvent.SpawnParticle +import Dodge.WorldEvent.ThingsHit import Geometry +import qualified IntMapHelp as IM import LensHelp +import qualified ListHelp as List import StreamingHelp -import qualified IntMapHelp as IM -import Data.Maybe -import Dodge.Movement.Turn -import Dodge.WorldEvent.ThingsHit +updateBullet :: World -> Bullet -> (World, Maybe Bullet) +updateBullet w bu = case _buDelayFraction bu of + 1 -> mvBullet 1 w bu + x -> mvBullet x w (bu & buDelayFraction .~ 1) -updateBullet :: World -> Bullet -> (World,Maybe Bullet) -updateBullet w bu = case _buState bu of - DelayedBullet x -> mvBullet x w bu - _ -> mvBullet 1 w bu +mvBullet :: Float -> World -> Bullet -> (World, Maybe Bullet) +mvBullet x w bu + | _buTimer bu <= 0 || magV (_buVel bu) < 1 = (endspawn w, Nothing) + | otherwise = + second (fmap updateBulVel) + . hitEffFromBul x w + $ applyMagnetsToBul bu w + where + endspawn = fromMaybe id $ do + partspawn <- bulletSpawn bu + return $ partspawn p + p = _buPos bu + +applyMagnetsToBul :: Bullet -> World -> Bullet +applyMagnetsToBul bu = + foldr (\mg -> doMagnetBuBu (_mgField mg) mg) bu . _magnets . _cWorld + +updateBulVel :: Bullet -> Bullet +updateBulVel bt = case _buTrajectory bt of + BasicBulletTrajectory -> bt & buVel .*.*~ _buDrag bt + MagnetTrajectory tpos -> bt & buVel %~ (clipV 20 . (+.+ 5 *.* normalizeV (tpos -.- _buPos bt))) + FlechetteTrajectory tpos -> bt & buVel %~ vecTurnTo 0.2 (_buPos bt) tpos + BezierTrajectory spos tpos xpos -> + let bf tm = bQuadToF (spos, xpos, tpos) $ (100 - tm) * 0.05 + in bt & buVel .~ bf (fromIntegral $ t - 1) -.- bf (fromIntegral t) + where + t = _buTimer bt useAmmoParams :: Item -> Creature -> World -> World -useAmmoParams it cr w = w & cWorld . instantBullets .:~ (_amBullet bultype - & buPos .~ sp - & buTrajectory %~ settrajectory - & buVel %~ (rotateV dir . (muzvel *.*)) - & buDrag *~ _rifling (_itParams it) - ) +useAmmoParams it cr w = + w & cWorld . instantBullets + .:~ ( _amBullet bultype + & buPos .~ sp + & buTrajectory %~ settrajectory + & buVel %~ (rotateV dir . (muzvel *.*)) + & buDrag *~ _rifling (_itParams it) + ) where sp = _crPos cr +.+ (muzlength + 10) *.* unitVectorAtAngle dir dir = _crDir cr - bultype = _laAmmoType $ _itConsumption it + bultype = _laAmmoType $ _heldConsumption $ _itUse it muzvel = _muzVel $ _itParams it muzlength = aimingMuzzlePos cr it settrajectory traj = case traj of @@ -49,35 +79,9 @@ useAmmoParams it cr w = w & cWorld . instantBullets .:~ (_amBullet bultype tpos <- it ^? itTargeting . tgPos . _Just return $ BezierTrajectory sp tpos (mouseWorldPos w) -{- Update for a generic bullet. -} -mvBullet :: Float -> World -> Bullet -> (World, Maybe Bullet) -mvBullet x w bt' - | t <= 0 || magV (_buVel bt) < 1 = (endspawn w,Nothing) - | otherwise = second (fmap dodrag) $ - hiteff bt hitstream w - where - endspawn w' = fromMaybe w' $ do - partspawn <- bulletSpawn bt' - return $ partspawn p w' - hitstream = thingsHit p (p +.+ vel) w - bt = foldr (\mg b -> doMagnetBuBu (_mgField mg) mg b) bt' (_magnets (_cWorld w)) - & buState .~ NormalBulletState - dodrag = case _buTrajectory bt of - BasicBulletTrajectory -> buVel .*.*~ drag - MagnetTrajectory tpos -> buVel .+.+~ 5 *.* normalizeV (tpos -.- _buPos bt) - FlechetteTrajectory tpos -> buVel %~ vecTurnTo 0.2 (_buPos bt) tpos - BezierTrajectory spos tpos xpos -> - let bf tm = bQuadToF (spos,xpos,tpos) $ (100 - tm) * 0.05 - in buVel .~ bf (fromIntegral $ _buTimer bt - 1) -.- bf (fromIntegral $ _buTimer bt) - drag = _buDrag bt - p = _buPos bt - vel = _buVel bt - hiteff = hitEffFromBul x - t = _buTimer bt - bounceDir :: (Point2, Either Creature Wall) -> Maybe Point2 -bounceDir (_,Right wl) | _wlBouncy wl = Just $ uncurry (-.-) (_wlLine wl) -bounceDir (p,Left cr) | crIsArmouredFrom p cr = Just $ vNormal $ p -.- _crPos cr +bounceDir (_, Right wl) | _wlBouncy wl = Just $ uncurry (-.-) (_wlLine wl) +bounceDir (p, Left cr) | crIsArmouredFrom p cr = Just $ vNormal $ p -.- _crPos cr bounceDir _ = Nothing bulletSpawn :: Bullet -> Maybe (Point2 -> World -> World) @@ -87,66 +91,84 @@ bulletSpawn bu = case _buSpawn bu of BulBall ConcBall -> Just $ \p -> cWorld . shockwaves .:~ concBall p BulBall TeslaBall -> Just makeStaticBall -hitEffFromBul :: Float -> Bullet - -> [(Point2, Either Creature Wall)] - -> World - -> (World,Maybe Bullet) -hitEffFromBul x bu hitstream w = case _buEffect bu of +hitEffFromBul :: + Float -> + World -> + Bullet -> + (World, Maybe Bullet) +hitEffFromBul x w bu = case _buEffect bu of PenetrateBullet -> movePenBullet x bu hitstream w - BounceBullet -> case List.safeHead hitstream of + BounceBullet -> case List.safeHead hitstream of Nothing -> (w, moveBullet x bu) - Just (hp,crwl) -> fromMaybe (expireAndDamage x bu hitstream w) $ do - dir <- bounceDir (hp,crwl) - return (w,Just $ bu - & buPos .~ hp +.+ normalizeV (_buPos bu -.- hp) - & buVel %~ reflectIn dir - & buTrajectory .~ BasicBulletTrajectory - & buTimer -~ 1 + Just (hp, crwl) -> fromMaybe (expireAndDamage x bu hitstream w) $ do + dir <- bounceDir (hp, crwl) + return + ( w + , Just $ + bu + & buPos .~ hp +.+ normalizeV (_buPos bu -.- hp) + & buVel %~ reflectIn dir + & buTrajectory .~ BasicBulletTrajectory + & buTimer -~ 1 ) DestroyBullet -> expireAndDamage x bu hitstream w + where + ep = sp +.+ x *.* _buVel bu + sp = _buPos bu + hitstream = thingsHit sp ep w setFromToDams :: Bullet -> Point2 -> [Damage] setFromToDams bu p = map f (_buDamages bu) where f = (dmFrom .~ _buPos bu) . (dmAt .~ p) . (dmTo .~ _buPos bu +.+ _buVel bu) -damageThingHit :: Bullet -> (Point2,Either Creature Wall) -> World -> World -damageThingHit bu (p,crwl) = case crwl of +damageThingHit :: Bullet -> (Point2, Either Creature Wall) -> World -> World +damageThingHit bu (p, crwl) = case crwl of Left cr -> cWorld . creatures . ix (_crID cr) . crState . csDamage .++~ dams Right wl -> cWorld . wallDamages %~ IM.insertWith (++) (_wlID wl) dams where dams = setFromToDams bu p - -expireAndDamage :: Float - -> Bullet - -> [(Point2, Either Creature Wall)] - -> World - -> (World, Maybe Bullet) + +expireAndDamage :: + Float -> + Bullet -> + [(Point2, Either Creature Wall)] -> + World -> + (World, Maybe Bullet) expireAndDamage y bt things w = case List.safeHead things of Nothing -> (w, moveBullet y bt) Just x -> (damageThingHit bt x w, destroyAt (fst x) bt) moveBullet :: Float -> Bullet -> Maybe Bullet -moveBullet x pt = Just $ pt - & buPos %~ (+.+ x *.* _buVel pt) - & buOldPos .~ _buPos pt - & buTimer -~ 1 +moveBullet x pt = + Just $ + pt + & buPos %~ (+.+ x *.* _buVel pt) + & buOldPos .~ _buPos pt + & buTimer -~ 1 destroyAt :: Point2 -> Bullet -> Maybe Bullet -destroyAt hitp pt = Just $ pt - & buPos .~ hitp +.+ normalizeV (p -.- hitp) - & buOldPos .~ p - & buVel .~ 0 +destroyAt hitp pt = + Just $ + pt + & buPos .~ hitp +.+ normalizeV (p -.- hitp) + & buOldPos .~ p + & buVel .~ 0 where p = _buPos pt -movePenBullet :: Float -> Bullet -> [(Point2, Either Creature Wall)] - -> World -> (World, Maybe Bullet) +movePenBullet :: + Float -> + Bullet -> + [(Point2, Either Creature Wall)] -> + World -> + (World, Maybe Bullet) movePenBullet x bu hitstream w = case hitstream of - [] -> (w,moveBullet x bu) - ((p,crwl):strm) -> if penThing crwl - then first (damageThingHit bu (p,crwl)) $ movePenBullet x bu strm w - else expireAndDamage x bu hitstream w + [] -> (w, moveBullet x bu) + ((p, crwl) : strm) -> + if penThing crwl + then first (damageThingHit bu (p, crwl)) $ movePenBullet x bu strm w + else expireAndDamage x bu hitstream w penThing :: Either Creature Wall -> Bool penThing (Left _) = True diff --git a/src/Dodge/Combine.hs b/src/Dodge/Combine.hs index c1962cb6f..02aa665b6 100644 --- a/src/Dodge/Combine.hs +++ b/src/Dodge/Combine.hs @@ -29,23 +29,23 @@ import qualified Data.Map.Strict as M import Data.Maybe import Data.List (scanl',sortOn) -invertInventory :: IM.IntMap Item -> [(ItemBaseType,IcAmount,Int)] +invertInventory :: IM.IntMap Item -> [(ItemBaseType,ItAmount,Int)] invertInventory = IM.foldrWithKey (\k it -> ((_iyBase $ _itType it, itStackAmount it,k) :) ) [] -splitIcAmounts :: [(ItemBaseType,IcAmount,Int)] -> [((IcAmount,ItemBaseType),(IcAmount,Int))] -splitIcAmounts = concatMap f +splitItAmounts :: [(ItemBaseType,ItAmount,Int)] -> [((ItAmount,ItemBaseType),(ItAmount,Int))] +splitItAmounts = concatMap f where f (x,n,y) = [((i,x),(i,y)) | i <- [1..n]] -lookupItems :: IM.IntMap Item -> [([(IcAmount,Int)],Item)] -lookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . splitIcAmounts . invertInventory +lookupItems :: IM.IntMap Item -> [([(ItAmount,Int)],Item)] +lookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . splitItAmounts . invertInventory combineItemListYouX :: World -> [([Int],Item)] combineItemListYouX = map (first $ concatMap g) . lookupItems . yourInv where - g (amount,i) = replicate (_toInt amount) i + g (amount,i) = replicate (_getItAmount amount) i combineListInfo :: World -> [([Int],([String],Item))] combineListInfo w = filter (f . snd . snd) . map (cmm inv) $ combineItemListYouX w diff --git a/src/Dodge/Combine/Combinations.hs b/src/Dodge/Combine/Combinations.hs index cbd9015dd..174c48246 100644 --- a/src/Dodge/Combine/Combinations.hs +++ b/src/Dodge/Combine/Combinations.hs @@ -14,7 +14,7 @@ import LensHelp --import Data.Maybe -itemCombinations :: [([(IcAmount,ItemBaseType)],Item)] +itemCombinations :: [([(ItAmount,ItemBaseType)],Item)] itemCombinations = [ po [CRAFT PIPE, CRAFT HARDWARE] (bangStick 1) , po [HELD (BANGSTICK 1), CRAFT TIN] pistol diff --git a/src/Dodge/Combine/Graph.hs b/src/Dodge/Combine/Graph.hs index 33f15e62c..04680ac07 100644 --- a/src/Dodge/Combine/Graph.hs +++ b/src/Dodge/Combine/Graph.hs @@ -19,7 +19,7 @@ data CombClust | JoinClust deriving (Eq,Ord,Show,Enum,Bounded) -newtype CombNode = CombNode {_unCombNode :: Either ItemBaseType [(IcAmount,ItemBaseType)]} +newtype CombNode = CombNode {_unCombNode :: Either ItemBaseType [(ItAmount,ItemBaseType)]} deriving (Eq,Ord,Show) instance Labellable CombNode where @@ -32,7 +32,7 @@ instance Labellable CombEdge where toLabelValue (CombEdge 0) = StrLabel (pack "") toLabelValue (CombEdge x) = StrLabel (pack $ show x) -bulletCombinations :: [([(IcAmount,ItemBaseType)],Item)] +bulletCombinations :: [([(ItAmount,ItemBaseType)],Item)] bulletCombinations = filter ( (`elem` map totype bulletWeapons) . totype @@ -63,7 +63,7 @@ itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) itemCombinat | otherwise = (CombNode $ Right abts,CombNode $ Left bt,0) : map g abts where bts = map snd abts - g (am,bt') = (CombNode $ Left bt',CombNode $ Right abts,_toInt am) + g (am,bt') = (CombNode $ Left bt',CombNode $ Right abts,_getItAmount am) combinationsGraph :: FGL.Gr CombNode CombEdge combinationsGraph = FGL.labnfilter (f . _unCombNode . snd) diff --git a/src/Dodge/Combine/Module.hs b/src/Dodge/Combine/Module.hs index 924e4a7bc..ac1a3ae5f 100644 --- a/src/Dodge/Combine/Module.hs +++ b/src/Dodge/Combine/Module.hs @@ -8,28 +8,28 @@ import Geometry moduleModification :: ItemModuleType -> Item -> Item moduleModification imt = case imt of EMPTYMODULE -> id - DRUMMAG -> itConsumption . laMax .~ 45 - BELTMAG -> itConsumption . laMax .~ 150 + DRUMMAG -> itUse . heldConsumption . laMax .~ 45 + BELTMAG -> itUse . heldConsumption . laMax .~ 150 MAGNETMAG -> itUse . useDelay . rateMax .~ 4 - INCENDBUL -> itConsumption . laAmmoType . amBullet . buSpawn .~ BulBall IncBall - BOUNCEBUL -> itConsumption . laAmmoType . amBullet . buEffect .~ BounceBullet - PENBUL -> itConsumption . laAmmoType . amBullet . buEffect .~ PenetrateBullet - STATICBUL -> itConsumption . laAmmoType . amBullet . buSpawn .~ BulBall TeslaBall - CONCUSBUL -> itConsumption . laAmmoType . amBullet . buSpawn .~ BulBall ConcBall + INCENDBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall IncBall + BOUNCEBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ BounceBullet + PENBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ PenetrateBullet + STATICBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall TeslaBall + CONCUSBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall ConcBall TARGCR -> itTargeting .~ targetRBCreature TARGLAS -> itTargeting .~ targetLaser TARGPOS -> itTargeting .~ targetRBPress - MAGNETTRAJ -> (itConsumption . laAmmoType . amBullet . buTrajectory .~ MagnetTrajectory 0) - . (itConsumption . laAmmoType . amBullet . buVel .~ V2 10 0) - FLECHETRAJ -> itConsumption . laAmmoType . amBullet . buTrajectory .~ FlechetteTrajectory 0 - BEZIERTRAJ -> itConsumption . laAmmoType . amBullet . buTrajectory .~ BezierTrajectory 0 0 0 + MAGNETTRAJ -> (itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ MagnetTrajectory 0) + . (itUse . heldConsumption . laAmmoType . amBullet . buVel .~ V2 10 0) + FLECHETRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ FlechetteTrajectory 0 + BEZIERTRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ BezierTrajectory 0 0 0 INCENDLAS -> itParams . lasBeam .~ BeamCombine FlameBeamCombine SPLITLAS -> itParams . lasBeam .~ BeamCombine SplitBeamCombine STATICLAS -> (itParams . lasBeam .~ BeamCombine TeslaBeamCombine) . (itParams . subParams ?~ teslaParams) WEPTELE -> makeDirectedTele - LAUNCHHOME -> itConsumption . laAmmoType . amPjCreation .~ CreateTrackingShell - EXTRABATTERY -> itConsumption . laMax +~ 1000 + LAUNCHHOME -> itUse . heldConsumption . laAmmoType . amPjCreation .~ CreateTrackingShell + EXTRABATTERY -> itUse . heldConsumption . laMax +~ 1000 ATTACHTORCH -> id where makeDirectedTele it = it diff --git a/src/Dodge/Combine/Trie.hs b/src/Dodge/Combine/Trie.hs index 55cfe514b..55b996131 100644 --- a/src/Dodge/Combine/Trie.hs +++ b/src/Dodge/Combine/Trie.hs @@ -11,7 +11,7 @@ import Data.Bifunctor --import Data.Map.Merge.Strict import Data.List (sort) -combinationsTrie :: Trie (IcAmount,ItemBaseType) Item +combinationsTrie :: Trie (ItAmount,ItemBaseType) Item {-# INLINE combinationsTrie #-} combinationsTrie = foldr (uncurry insertInTrie . first sort) diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs deleted file mode 100644 index 456d5c109..000000000 --- a/src/Dodge/Config/Data.hs +++ /dev/null @@ -1,112 +0,0 @@ ---{-# LANGUAGE FlexibleInstances #-} ---{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StrictData #-} -module Dodge.Config.Data where -import Data.Aeson -import qualified Data.Set as S -import GHC.Generics -import Control.Lens ---import Data.Enum.Set.Base -{-# ANN module "HLint: ignore Use camelCase" #-} -data Configuration = Configuration - { _volume_master :: Float - , _volume_sound :: Float - , _volume_music :: Float - , _graphics_wall_textured :: Bool - , _graphics_cloud_shadows :: Bool - , _graphics_object_shadows :: Bool - , _graphics_resolution_factor :: ResFactor - , _windowX :: Float - , _windowY :: Float - , _windowPosX :: Int - , _windowPosY :: Int - , _gameplay_rotate_to_wall :: Bool - , _debug_view_clip_bounds :: RoomClipping - , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet - } - deriving (Generic, Show) -data DebugBool - = Show_ms_frame - | Show_debug - | Show_sound - | Noclip - | Cr_status - | Cr_awareness - | Mouse_position - | View_boundaries - | Walls_info - | Pathing - | Remove_LOS - | Cull_more_lights - | Close_shape_culling - | Show_bound_box - | Bound_box_screen - | Show_wall_search_rays - | Show_dda_test - | Show_far_wall_detect - | Show_select - | Inspect_wall - | Show_nodes_near_select - | Show_path_between - deriving (Generic, Eq,Ord,Bounded, Enum, Show) -data ResFactor = FullRes | HalfRes | QuarterRes - deriving (Generic, Show, Eq, Ord, Enum, Bounded) -instance ToJSON ResFactor where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ResFactor -data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries - deriving (Generic, Show, Eq, Ord, Enum, Bounded) -instance ToJSON RoomClipping where - toEncoding = genericToEncoding defaultOptions -instance FromJSON RoomClipping -resFactorNum :: ResFactor -> Int -resFactorNum rf = case rf of - FullRes -> 1 - HalfRes -> 2 - QuarterRes -> 4 - -makeLenses ''Configuration -instance ToJSON DebugBool where - toEncoding = genericToEncoding defaultOptions - -instance ToJSON Configuration where - toEncoding = genericToEncoding defaultOptions - ---deriving instance Generic a => Generic (EnumSet Word a) ---instance FromJSON (EnumSet Word a) - -instance FromJSON DebugBool -instance FromJSON Configuration - -defaultConfig :: Configuration -defaultConfig = Configuration - { _volume_master = 1 - , _volume_sound = 1 - , _volume_music = 1 - , _graphics_wall_textured = True - , _graphics_cloud_shadows = True - , _graphics_object_shadows = True - , _graphics_resolution_factor = FullRes - , _windowX = 800 - , _windowY = 600 - , _windowPosX = 0 - , _windowPosY = 0 - , _gameplay_rotate_to_wall = True - , _debug_booleans = S.singleton Show_ms_frame - , _debug_view_clip_bounds = NoRoomClipBoundaries --- , _debug_show_sound = False --- , _debug_seconds_frame = True --- , _debug_noclip = False --- , _debug_mouse_position = False --- , _debug_cr_status = False --- , _debug_cr_awareness = False --- , _debug_view_boundaries = False --- , _debug_pathing = False --- , _debug_walls = False --- , _debug_remove_LOS = False --- , _debug_cull_more_lights = False - } -debugOn :: DebugBool -> Configuration -> Bool -debugOn db = S.member db . _debug_booleans diff --git a/src/Dodge/Config/Load.hs b/src/Dodge/Config/Load.hs index 030cc15b4..5e88a35e5 100644 --- a/src/Dodge/Config/Load.hs +++ b/src/Dodge/Config/Load.hs @@ -1,22 +1,22 @@ -module Dodge.Config.Load - ( loadDodgeConfig - ) where -import Dodge.Config.Data +module Dodge.Config.Load ( + loadDodgeConfig, +) where import Data.Aeson +import Dodge.Data.Config import System.Directory loadDodgeConfig :: IO Configuration loadDodgeConfig = do fExists <- doesFileExist "data/dodge.config.json" if fExists - then do - mayConfig <- decodeFileStrict "data/dodge.config.json" - case mayConfig of - Just config -> return config - Nothing -> do - putStrLn "invalid data/dodge.config.json, loading defaults" + then do + mayConfig <- decodeFileStrict "data/dodge.config.json" + case mayConfig of + Just config -> return config + Nothing -> do + putStrLn "invalid data/dodge.config.json, loading defaults" + return defaultConfig + else do + putStrLn "No data/data/dodge.config.json found, loading defaults" return defaultConfig - else do - putStrLn "No data/data/dodge.config.json found, loading defaults" - return defaultConfig diff --git a/src/Dodge/Config/Update.hs b/src/Dodge/Config/Update.hs index f663c5f9d..0a38ee412 100644 --- a/src/Dodge/Config/Update.hs +++ b/src/Dodge/Config/Update.hs @@ -1,51 +1,53 @@ -{-| +{- | IO actions that apply config side effects and save configuration settings to disk. -} -module Dodge.Config.Update - ( saveConfig - , setVolThen - , applyWorldConfig - , setVol - ) where ---import Dodge.Data.SoundOrigin -import Dodge.Config.Data -import Sound -import Data.Preload -import Preload.Update +module Dodge.Config.Update ( + saveConfig, + setVolThen, + applyWorldConfig, + setVol, +) where import qualified Data.Aeson.Encode.Pretty as AEP import qualified Data.ByteString.Lazy as BS ---import Control.Monad (when) +import Data.Preload +import Dodge.Data.Config +import Preload.Update +import Sound + {- | Write the current world configuration to disk as a json file. - -} +-} saveConfig :: Configuration -> (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" - $ AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) cfig + BS.writeFile "data/dodge.config.json" $ + AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) cfig f x + {- | Apply the volume settings from the world configuration to the running game. - -} +-} setVol :: Configuration -> IO () setVol cfig = do - setSoundVolume ( _volume_master cfig * _volume_sound cfig) - setMusicVolume ( _volume_master cfig * _volume_music cfig) + setSoundVolume (_volume_master cfig * _volume_sound cfig) + setMusicVolume (_volume_master cfig * _volume_music cfig) + -- what? setVolThen :: Configuration -> (a -> IO a) -> a -> IO a setVolThen cfig f a = do - setVol cfig + setVol cfig f a + {- | Apply /all/ of the values in the world configuration to the running game. - -} -applyWorldConfig - :: Configuration - -> PreloadData - -> IO PreloadData +-} +applyWorldConfig :: + Configuration -> + PreloadData -> + IO PreloadData applyWorldConfig cfig pdata = do - setVol cfig + setVol cfig pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y pdata where x = round $ _windowX cfig diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index 98166d6dd..0d2e87cfb 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -1,97 +1,101 @@ -module Dodge.Creature.Impulse.UseItem - ( useItem - , useLeftItem - , itemEffect - ) where -import Dodge.Data -import Dodge.Luse -import Dodge.Cuse -import Dodge.Euse -import Dodge.Inventory -import Dodge.Reloading -import Dodge.Item.Location -import Dodge.HeldUse +module Dodge.Creature.Impulse.UseItem ( + useItem, + useLeftItem, + itemEffect, +) where -import qualified IntMapHelp as IM -import qualified Data.Map.Strict as M -import qualified SDL --import qualified Data.IntSet as IS import Control.Lens +import qualified Data.Map.Strict as M import Data.Maybe +import Dodge.Cuse +import Dodge.Data +import Dodge.Euse +import Dodge.HeldUse +import Dodge.Inventory +import Dodge.Item.Location +import Dodge.Luse +import Dodge.Reloading +import qualified IntMapHelp as IM +import qualified SDL useItem :: Creature -> World -> World useItem cr' w = fromMaybe (f w) $ do - cr <- w ^? cWorld . creatures . ix (_crID cr') + cr <- w ^? cWorld . creatures . ix (_crID cr') it <- cr ^? crInv . ix (crSel cr) return $ itemEffect cr it w where f = cWorld . creatures . ix (_crID cr') . crHammerPosition .~ HammerDown itemEffect :: Creature -> Item -> World -> World -itemEffect cr it w = case it ^? itUse of - Just RightUse {_rUse = eff,_useMods = usemods} - -> hammerTest $ tryReload cr it w $ foldr ($) (useHeld eff) (useMod usemods) it cr - Just LeftUse {} -> doequipmentchange - Just EquipUse{} -> doequipmentchange +itemEffect cr it w = case it ^. itUse of + RightUse{_rUse = eff, _useMods = usemods} -> + hammerTest $ tryReload cr it w $ foldr ($) (useHeld eff) (useMod usemods) it cr + LeftUse{} -> doequipmentchange + EquipUse{} -> doequipmentchange -- ConsumeUse will cause problems if the item is not selected - Just (ConsumeUse eff) -> setuhamdown $ hammerTest $ useC eff it cr . rmInvItem (_crID cr) (crSel cr) - Just NoUse -> setuhamdown w - Nothing -> setuhamdown w + (ConsumeUse eff _) -> setuhamdown $ hammerTest $ useC eff it cr . rmInvItem (_crID cr) (crSel cr) + CraftUse{} -> setuhamdown w where hammerTest f = case _crHammerPosition cr of HammerUp -> f w _ -> w & setuhamdown setuhamdown = cWorld . creatures . ix (_crID cr) . crHammerPosition .~ HammerDown - doequipmentchange = setuhamdown $ hammerTest (toggleEquipmentAt (_rbOptions w) (crSel cr) cr - . activateEquipmentAt (_rbOptions w) cr) + doequipmentchange = + setuhamdown $ + hammerTest + ( toggleEquipmentAt (_rbOptions w) (crSel cr) cr + . activateEquipmentAt (_rbOptions w) cr + ) tryReload :: Creature -> Item -> World -> (World -> World) -> World -> World tryReload cr it w f - | _crID cr == _yourID (_cWorld w) && itNeedsLoading it && _mouseButtons w M.!? SDL.ButtonLeft == Just False - = crToggleReloading cr - | otherwise - = (runIdentity . pointToItem (_itPos it) (return . (itUse . useHammer .~ HammerDown))) - . f + | _crID cr == _yourID (_cWorld w) && itNeedsLoading it && _mouseButtons w M.!? SDL.ButtonLeft == Just False = + crToggleReloading cr + | otherwise = + (runIdentity . pointerToItem (_itPos it) (return . (itUse . useHammer .~ HammerDown))) + . f itNeedsLoading :: Item -> Bool itNeedsLoading it = _laLoaded ic == 0 || not (_laPrimed ic) where - ic = _itConsumption it + ic = _heldConsumption (_itUse it) activateEquipmentAt :: RightButtonOptions -> Creature -> World -> World -activateEquipmentAt rbo cr = cWorld . creatures . ix (_crID cr) %~ case (rbo ^? opActivateEquipment . activateEquipment, rbo ^? opActivateEquipment . deactivateEquipment) of - (Just i,_) -> crLeftInvSel ?~ i - (_,Just _) -> crLeftInvSel .~ Nothing - _ -> id +activateEquipmentAt rbo cr = + cWorld . creatures . ix (_crID cr) %~ case (rbo ^? opActivateEquipment . activateEquipment, rbo ^? opActivateEquipment . deactivateEquipment) of + (Just i, _) -> crLeftInvSel ?~ i + (_, Just _) -> crLeftInvSel .~ Nothing + _ -> id toggleEquipmentAt :: RightButtonOptions -> Int -> Creature -> World -> World toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of Just DoNotMoveEquipment -> w - Just PutOnEquipment {_allocNewPos = newp} - -> w + Just PutOnEquipment{_allocNewPos = newp} -> + w & crpoint . crEquipment . at newp ?~ invid & crpoint . crInvEquipped . at invid ?~ newp & onequip itm cr - Just MoveEquipment {_allocNewPos=newp,_allocOldPos = oldp } - -> w + Just MoveEquipment{_allocNewPos = newp, _allocOldPos = oldp} -> + w & crpoint . crEquipment . at newp ?~ invid & crpoint . crEquipment . at oldp .~ Nothing & crpoint . crInvEquipped . at invid ?~ newp - Just SwapEquipment {_allocNewPos=newp, _allocOldPos = oldp, _allocSwapID = sid } - -> w + Just SwapEquipment{_allocNewPos = newp, _allocOldPos = oldp, _allocSwapID = sid} -> + w & crpoint . crEquipment . at newp ?~ invid & crpoint . crEquipment . at oldp ?~ sid & crpoint . crInvEquipped . at invid ?~ newp & crpoint . crInvEquipped . at sid ?~ oldp - Just ReplaceEquipment {_allocNewPos = newp, _allocRemoveID = rid } - -> w + Just ReplaceEquipment{_allocNewPos = newp, _allocRemoveID = rid} -> + w & crpoint . crEquipment . at newp ?~ invid & crpoint . crInvEquipped . at invid ?~ newp & crpoint . crInvEquipped . at rid .~ Nothing & onremove (itmat rid) cr & onequip itm cr - Just RemoveEquipment {_allocOldPos = oldp } - -> w + Just RemoveEquipment{_allocOldPos = oldp} -> + w & crpoint . crEquipment . at oldp .~ Nothing & crpoint . crInvEquipped . at invid .~ Nothing & onremove itm cr @@ -104,21 +108,23 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of onremove itm' = useE ((_eqOnRemove . _eqEq . _itUse) itm') itm' useLeftItem :: Int -> World -> World -useLeftItem cid w +useLeftItem cid w | _crInvLock cr = w | itmShouldBeUsed = useItem cr w -- I believe this ONLY sets equipment options | otherwise = fromMaybe w $ do invid <- _crLeftInvSel cr itm <- cr ^? crInv . ix invid - f <- cr ^? crInv . ix invid . itUse . lUse - return - . (runIdentity . pointToItem (_itPos itm) (return . (itUse . useHammer .~ HammerDown))) - . useL f itm cr + f <- cr ^? crInv . ix invid . itUse . lUse + return + . (runIdentity . pointerToItem (_itPos itm) (return . (itUse . useHammer .~ HammerDown))) + . useL f itm cr $ w where cr = _creatures (_cWorld w) IM.! cid - itmShouldBeUsed = isJust (cr ^? crInv . ix (crSel cr) . itUse . cUse) - || ( isJust (cr ^? crInv . ix (crSel cr) . itUse . eqEq . eqUse) - && _crLeftInvSel cr /= Just (crSel cr) - ) - -- TODO determine itmShouldBeUsed with reference to config options + itmShouldBeUsed = + isJust (cr ^? crInv . ix (crSel cr) . itUse . cUse) + || ( isJust (cr ^? crInv . ix (crSel cr) . itUse . eqEq . eqUse) + && _crLeftInvSel cr /= Just (crSel cr) + ) + +-- TODO determine itmShouldBeUsed with reference to config options diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index b0acb40a5..ee866d016 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -135,7 +135,7 @@ doStrategyActions cr = case cr ^? crActionPlan . apStrategy of reloadOverride :: Creature -> Creature reloadOverride cr - | cr ^? crInv . ix (crSel cr) . itConsumption . laLoaded == Just 0 + | cr ^? crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded == Just 0 && cr ^. crStance . posture == Aiming = cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions | otherwise = cr diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 03117049d..0d3508598 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -216,10 +216,10 @@ itemUpdate cr i . (itPos .~ InInv (_crID cr) i) . (itIsHeld .~ bool) updateAutoRecharge :: Item -> Item -updateAutoRecharge it = case _itConsumption it of - AutoRecharging l m t p - | l < m && p <= 0 -> it & itConsumption .~ AutoRecharging (l+1) m t t - | l < m -> it & itConsumption . arProgress -~ 1 +updateAutoRecharge it = case it ^? itUse . leftConsumption of + Just (AutoRecharging l m t p) + | l < m && p <= 0 -> it & itUse . leftConsumption .~ AutoRecharging (l+1) m t t + | l < m -> it & itUse . leftConsumption . arProgress -~ 1 _ -> it doItemTargeting :: Int -> Creature -> World -> World doItemTargeting invid cr w = case cr ^? crInv . ix invid . itTargeting of diff --git a/src/Dodge/Creature/Statistics.hs b/src/Dodge/Creature/Statistics.hs index 16e9658bc..de1cd82b8 100644 --- a/src/Dodge/Creature/Statistics.hs +++ b/src/Dodge/Creature/Statistics.hs @@ -1,16 +1,16 @@ -module Dodge.Creature.Statistics - ( getCrStrength - , getCrDexterity - ) where -import Dodge.Data +module Dodge.Creature.Statistics ( + getCrStrength, + getCrDexterity, +) where + +--import Data.Strict.IntMap.Autogen.Merge.Strict +import Data.IntMap.Merge.Strict +import Data.Maybe import Dodge.Creature.Test +import Dodge.Data import qualified IntMapHelp as IM import LensHelp -import Data.Maybe -import Data.Strict.IntMap.Autogen.Merge.Strict ---import Data.IntMap.Merge.Strict - getCrDexterity :: Creature -> Int getCrDexterity cr = _dexterity (_crStatistics cr) @@ -23,16 +23,20 @@ strFromEquipment = sum . fmap equipmentStrValue . crCurrentEquipment equipmentStrValue :: Item -> Int equipmentStrValue itm = case _iyBase $ _itType itm of EQUIP FRONTARMOUR -> negate 3 - EQUIP POWERLEGS -> 3 + EQUIP POWERLEGS -> 3 _ -> 0 crCurrentEquipment :: Creature -> IM.IntMap Item -crCurrentEquipment cr = merge dropMissing dropMissing (zipWithMatched (\_ _ itm -> itm)) - (_crInvEquipped cr) - (_crInv cr) +crCurrentEquipment cr = + merge + dropMissing + dropMissing + (zipWithMatched (\_ _ itm -> itm)) + (_crInvEquipped cr) + (_crInv cr) strFromHeldItem :: Creature -> Int strFromHeldItem cr - | _posture (_crStance cr) == Aiming || crIsReloading cr - = negate $ fromMaybe 0 $ cr ^? crInv . ix (crSel cr) . itUse . useAim . aimWeight + | _posture (_crStance cr) == Aiming || crIsReloading cr = + negate $ fromMaybe 0 $ cr ^? crInv . ix (crSel cr) . itUse . useAim . aimWeight | otherwise = 0 diff --git a/src/Dodge/Creature/Test.hs b/src/Dodge/Creature/Test.hs index 5673c7549..67ecc5cec 100644 --- a/src/Dodge/Creature/Test.hs +++ b/src/Dodge/Creature/Test.hs @@ -41,7 +41,7 @@ crIsReloading cr = case cr ^? crInvSel . iselAction of crWeaponReady :: Creature -> Bool crWeaponReady cr = fromMaybe False $ do - ic <- cr ^? crInv . ix (crSel cr) . itConsumption + ic <- cr ^? crInv . ix (crSel cr) . itUse . heldConsumption return (_laLoaded ic > 0 && _laPrimed ic) crCanSeeCr :: Creature -> (World, Creature) -> Bool diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 338487016..d5d65d849 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -22,8 +22,6 @@ module Dodge.Data ( module Dodge.Data.WorldEffect, module Dodge.Data.Button, module Dodge.Data.Beam, - module Dodge.Data.Targeting, - module Dodge.Data.ItEffect, module Dodge.Data.Hammer, module Dodge.Data.ArcStep, module Dodge.Data.CrWlID, @@ -54,14 +52,12 @@ module Dodge.Data ( module Dodge.Data.Zoning, module Dodge.Data.Bounds, module Dodge.Data.Sensor, - module Dodge.Combine.Data, - module Dodge.Distortion.Data, + module Dodge.Data.Distortion, module Dodge.Data.Damage, module Dodge.Data.SoundOrigin, - module Dodge.Config.Data, + module Dodge.Data.Config, module MaybeHelp, - module Dodge.Data.ItemAmount, - module Dodge.RoomCluster.Data, + module Dodge.Data.RoomCluster, module Dodge.Data.Room, module Dodge.Data.RadarBlip, module Dodge.Data.PathGraph, @@ -93,8 +89,7 @@ import Data.Preload import qualified Data.Set as S import qualified Data.Text as T import Data.Tile -import Dodge.Combine.Data -import Dodge.Config.Data +import Dodge.Data.Config import Dodge.Config.KeyConfig import Dodge.Data.ActionPlan import Dodge.Data.Ammo @@ -122,9 +117,7 @@ import Dodge.Data.GenParams import Dodge.Data.Gust import Dodge.Data.HUD import Dodge.Data.Hammer -import Dodge.Data.ItEffect import Dodge.Data.Item -import Dodge.Data.ItemAmount import Dodge.Data.Laser import Dodge.Data.LightSource import Dodge.Data.LinearShockwave @@ -149,15 +142,14 @@ import Dodge.Data.Sensor import Dodge.Data.Shockwave import Dodge.Data.SoundOrigin import Dodge.Data.Spark -import Dodge.Data.Targeting import Dodge.Data.Terminal import Dodge.Data.TeslaArc import Dodge.Data.TractorBeam import Dodge.Data.Wall import Dodge.Data.WorldEffect import Dodge.Data.Zoning -import Dodge.Distortion.Data -import Dodge.RoomCluster.Data +import Dodge.Data.Distortion +import Dodge.Data.RoomCluster import GHC.Generics import Geometry.Data import qualified IntMapHelp as IM diff --git a/src/Dodge/Data/ActionPlan.hs b/src/Dodge/Data/ActionPlan.hs index 050ba1eb8..d1a615a6e 100644 --- a/src/Dodge/Data/ActionPlan.hs +++ b/src/Dodge/Data/ActionPlan.hs @@ -1,15 +1,13 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} ---{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} module Dodge.Data.ActionPlan where import Control.Lens import Data.Aeson +import Data.Aeson.TH import Dodge.Data.Creature.Stance import Dodge.Data.CreatureEffect -import GHC.Generics import Geometry.Data import Sound.Data @@ -21,22 +19,12 @@ data ActionPlan , _apStrategy :: Strategy , _apGoal :: [Goal] } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON ActionPlan where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON ActionPlan + deriving (Eq, Ord, Show, Read) data RandImpulse = RandImpulseList [Impulse] | RandImpulseCircMove Float - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON RandImpulse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON RandImpulse + deriving (Eq, Ord, Show, Read) data Impulse = Move Point2 @@ -70,12 +58,7 @@ data Impulse { _impulseUseAheadPos :: P2Imp } | ImpulseNothing - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Impulse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Impulse + deriving (Eq, Ord, Show, Read) infixr 9 `WaitThen` @@ -182,12 +165,7 @@ data Action { _sideImpulses :: [Impulse] , _mainAction :: Action } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Action where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Action + deriving (Eq, Ord, Show, Read) data Strategy = Flank Int @@ -205,24 +183,20 @@ data Strategy | Reload | Flee | MeleeStrike - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Strategy where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Strategy + deriving (Eq, Ord, Show, Read) data Goal = LiveLongAndProsper | Kill Int | SentinelAt Point2 Float - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Goal where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Goal + deriving (Eq, Ord, Show, Read) +deriveJSON defaultOptions ''ActionPlan +deriveJSON defaultOptions ''RandImpulse +deriveJSON defaultOptions ''Impulse +deriveJSON defaultOptions ''Action +deriveJSON defaultOptions ''Strategy +deriveJSON defaultOptions ''Goal makeLenses ''ActionPlan makeLenses ''Impulse makeLenses ''Action diff --git a/src/Dodge/Data/Ammo.hs b/src/Dodge/Data/Ammo.hs index c02d67b8f..2339008e9 100644 --- a/src/Dodge/Data/Ammo.hs +++ b/src/Dodge/Data/Ammo.hs @@ -1,36 +1,32 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Ammo where -import GHC.Generics + +import Control.Lens import Data.Aeson -import Dodge.Data.Payload +import Data.Aeson.TH import Dodge.Data.Bullet import Dodge.Data.Gas +import Dodge.Data.Payload import Dodge.Data.Wall -import Control.Lens + data ProjectileDraw = DrawShell | DrawRemoteShell | DrawDrone | DrawBlankProjectile - deriving (Show,Read,Eq,Ord,Enum,Bounded,Generic) -instance ToJSON ProjectileDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ProjectileDraw + deriving (Show, Read, Eq, Ord, Enum, Bounded) + data ProjectileCreate = CreateShell | CreateTrackingShell - deriving (Show,Read,Eq,Ord,Enum,Bounded,Generic) -instance ToJSON ProjectileCreate where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ProjectileCreate -data ProjectileUpdate + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +data ProjectileUpdate = PJThrust {_pjuStart :: Int, _pjuEnd :: Int} - | PJSpin {_pjuTime :: Int, _pjuCID :: Int, _pjuSpinAmound :: Int} - | PJTrack {_pjuStart :: Int, _pjuEnd :: Int, _pjuITID :: Int} + | PJSpin {_pjuTime :: Int, _pjuCID :: Int, _pjuSpinAmound :: Int} + | PJTrack {_pjuStart :: Int, _pjuEnd :: Int, _pjuITID :: Int} | PJReduceSpin {_pjuReduceSpin :: Float} | PJRemoteDirection {_pjuStart :: Int, _pjuEnd :: Int, _pjuCID :: Int, _pjuITID :: Int} | PJSetScope {_pjuITID :: Int} | PJRetireRemote {_pjuITID :: Int, _pjuTimer :: Int, _pjuPJID :: Int} - deriving (Show,Read,Eq,Ord,Generic) -instance ToJSON ProjectileUpdate where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ProjectileUpdate + deriving (Show, Read, Eq, Ord) + data AmmoType = ProjectileAmmo { _amPayload :: Payload @@ -39,22 +35,24 @@ data AmmoType , _amPjCreation :: ProjectileCreate } | BulletAmmo - { _amString :: String + { _amString :: String , _amBullet :: Bullet } | DroneAmmo - { _amString :: String } + {_amString :: String} | GasAmmo - { _amString :: String + { _amString :: String , _amCreateGas :: GasCreate } | ForceFieldAmmo { _amForceFieldType :: Wall } | GenericAmmo - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON AmmoType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON AmmoType + deriving (Eq, Ord, Show, Read) + makeLenses ''ProjectileUpdate makeLenses ''AmmoType +deriveJSON defaultOptions ''ProjectileDraw +deriveJSON defaultOptions ''ProjectileCreate +deriveJSON defaultOptions ''ProjectileUpdate +deriveJSON defaultOptions ''AmmoType diff --git a/src/Dodge/Data/Bullet.hs b/src/Dodge/Data/Bullet.hs index ef3c2ebcc..8c3f5ba35 100644 --- a/src/Dodge/Data/Bullet.hs +++ b/src/Dodge/Data/Bullet.hs @@ -1,66 +1,57 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Bullet where -import GHC.Generics + +import Control.Lens import Data.Aeson +import Data.Aeson.TH import Dodge.Data.Damage import Geometry.Data -import Control.Lens + data Bullet = Bullet - { _buState :: BulletState - , _buEffect :: BulletEffect - , _buSpawn :: BulletSpawn - , _buUpdateMod :: BulletUpdateMod + { _buDelayFraction :: Float + , _buEffect :: BulletEffect + , _buSpawn :: BulletSpawn + , _buUpdateMod :: BulletUpdateMod , _buTrajectory :: BulletTrajectory - , _buVel :: Point2 - , _buDrag :: Float - , _buPos :: Point2 - , _buOldPos :: Point2 - , _buWidth :: Float - , _buTimer :: Int - , _buDamages :: [Damage] + , _buVel :: Point2 + , _buDrag :: Float + , _buPos :: Point2 + , _buOldPos :: Point2 + , _buWidth :: Float + , _buTimer :: Int + , _buDamages :: [Damage] } - deriving (Show,Read,Eq,Ord,Generic) -instance ToJSON Bullet where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Bullet + deriving (Show, Read, Eq, Ord) + data EnergyBallType = IncBall | TeslaBall | ConcBall - deriving (Show,Read,Eq,Ord,Enum,Bounded,Generic) -instance ToJSON EnergyBallType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON EnergyBallType -data BulletState = NormalBulletState - | DelayedBullet Float - deriving (Show,Read,Eq,Ord,Generic) -instance ToJSON BulletState where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BulletState + deriving (Show, Read, Eq, Ord, Enum, Bounded) + data BulletUpdateMod = NoBulletUpdateMod - deriving (Show,Read,Eq,Ord,Enum,Bounded,Generic) -instance ToJSON BulletUpdateMod where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BulletUpdateMod -data BulletEffect + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +data BulletEffect = DestroyBullet | BounceBullet | PenetrateBullet - deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) -instance ToJSON BulletEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BulletEffect + deriving (Eq, Ord, Show, Read, Enum, Bounded) + data BulletSpawn = BulBall EnergyBallType | BulSpark - deriving (Show,Read,Eq,Ord,Generic) -instance ToJSON BulletSpawn where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BulletSpawn + deriving (Show, Read, Eq, Ord) + data BulletTrajectory = BasicBulletTrajectory | BezierTrajectory Point2 Point2 Point2 | FlechetteTrajectory Point2 | MagnetTrajectory Point2 - deriving (Show,Read,Eq,Ord,Generic) -instance ToJSON BulletTrajectory where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BulletTrajectory + deriving (Show, Read, Eq, Ord) + makeLenses ''Bullet +deriveJSON defaultOptions ''Bullet +deriveJSON defaultOptions ''EnergyBallType +deriveJSON defaultOptions ''BulletUpdateMod +deriveJSON defaultOptions ''BulletEffect +deriveJSON defaultOptions ''BulletSpawn +deriveJSON defaultOptions ''BulletTrajectory diff --git a/src/Dodge/Data/Button.hs b/src/Dodge/Data/Button.hs index 16c67e0c8..fb2312d42 100644 --- a/src/Dodge/Data/Button.hs +++ b/src/Dodge/Data/Button.hs @@ -38,7 +38,7 @@ data ButtonEvent = ButtonDoNothing ,_boffEff :: WdWd } | ButtonAccessTerminal - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq,Show,Read,Generic) instance ToJSON ButtonEvent where toEncoding = genericToEncoding defaultOptions instance FromJSON ButtonEvent @@ -54,7 +54,7 @@ data Button = Button , _btName :: String , _btColor :: Color } - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq,Show,Read,Generic) instance ToJSON Button where toEncoding = genericToEncoding defaultOptions instance FromJSON Button diff --git a/src/Dodge/Data/CWorld.hs b/src/Dodge/Data/CWorld.hs index 0461ff1e8..fe971d6a7 100644 --- a/src/Dodge/Data/CWorld.hs +++ b/src/Dodge/Data/CWorld.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -module Dodge.Data.CWorld where +module Dodge.Data.CWorld ( + module Dodge.Data.CWorld, +) where import Control.Lens import Data.Aeson +import Data.Aeson.TH import Data.Graph.Inductive import qualified Data.IntSet as IS import Dodge.Data.Beam @@ -18,6 +20,7 @@ import Dodge.Data.Corpse import Dodge.Data.CrGroupParams import Dodge.Data.Creature import Dodge.Data.Damage +import Dodge.Data.Distortion import Dodge.Data.Door import Dodge.Data.EnergyBall import Dodge.Data.Flame @@ -48,9 +51,7 @@ import Dodge.Data.TeslaArc import Dodge.Data.TractorBeam import Dodge.Data.Wall import Dodge.Data.WorldEffect -import Dodge.Distortion.Data import Dodge.GameRoom -import GHC.Generics import Geometry.ConvexPoly import Geometry.Data import qualified IntMapHelp as IM @@ -135,12 +136,6 @@ data CWorld = CWorld , _genParams :: GenParams , _deathDelay :: Maybe Int } - deriving (Eq, Show, Read, Generic) - -instance ToJSON CWorld where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CWorld data WorldBeams = WorldBeams { _blockingBeams :: [Beam] @@ -148,12 +143,9 @@ data WorldBeams = WorldBeams , _positronBeams :: [Beam] , _electronBeams :: [Beam] } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON WorldBeams where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON WorldBeams + deriving (Eq, Ord, Show, Read) +deriveJSON defaultOptions ''CWorld +deriveJSON defaultOptions ''WorldBeams makeLenses ''CWorld makeLenses ''WorldBeams diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs new file mode 100644 index 000000000..4a333b7da --- /dev/null +++ b/src/Dodge/Data/Config.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Config where + +import Control.Lens +import Data.Aeson +import qualified Data.Set as S +import GHC.Generics + +{-# ANN module "HLint: ignore Use camelCase" #-} + +data Configuration = Configuration + { _volume_master :: Float + , _volume_sound :: Float + , _volume_music :: Float + , _graphics_wall_textured :: Bool + , _graphics_cloud_shadows :: Bool + , _graphics_object_shadows :: Bool + , _graphics_resolution_factor :: ResFactor + , _windowX :: Float + , _windowY :: Float + , _windowPosX :: Int + , _windowPosY :: Int + , _gameplay_rotate_to_wall :: Bool + , _debug_view_clip_bounds :: RoomClipping + , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet + } + deriving (Generic, Show) + +data DebugBool + = Show_ms_frame + | Show_debug + | Show_sound + | Noclip + | Cr_status + | Cr_awareness + | Mouse_position + | View_boundaries + | Walls_info + | Pathing + | Remove_LOS + | Cull_more_lights + | Close_shape_culling + | Show_bound_box + | Bound_box_screen + | Show_wall_search_rays + | Show_dda_test + | Show_far_wall_detect + | Show_select + | Inspect_wall + | Show_nodes_near_select + | Show_path_between + deriving (Generic, Eq, Ord, Bounded, Enum, Show) + +data ResFactor = FullRes | HalfRes | QuarterRes + deriving (Generic, Show, Eq, Ord, Enum, Bounded) + +instance ToJSON ResFactor where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON ResFactor + +data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries + deriving (Generic, Show, Eq, Ord, Enum, Bounded) + +instance ToJSON RoomClipping where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON RoomClipping + +resFactorNum :: ResFactor -> Int +resFactorNum rf = case rf of + FullRes -> 1 + HalfRes -> 2 + QuarterRes -> 4 + +makeLenses ''Configuration + +instance ToJSON DebugBool where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON DebugBool + +instance ToJSON Configuration where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Configuration + +defaultConfig :: Configuration +defaultConfig = + Configuration + { _volume_master = 1 + , _volume_sound = 1 + , _volume_music = 1 + , _graphics_wall_textured = True + , _graphics_cloud_shadows = True + , _graphics_object_shadows = True + , _graphics_resolution_factor = FullRes + , _windowX = 800 + , _windowY = 600 + , _windowPosX = 0 + , _windowPosY = 0 + , _gameplay_rotate_to_wall = True + , _debug_booleans = S.singleton Show_ms_frame + , _debug_view_clip_bounds = NoRoomClipBoundaries + -- , _debug_show_sound = False + -- , _debug_seconds_frame = True + -- , _debug_noclip = False + -- , _debug_mouse_position = False + -- , _debug_cr_status = False + -- , _debug_cr_awareness = False + -- , _debug_view_boundaries = False + -- , _debug_pathing = False + -- , _debug_walls = False + -- , _debug_remove_LOS = False + -- , _debug_cull_more_lights = False + } + +debugOn :: DebugBool -> Configuration -> Bool +debugOn db = S.member db . _debug_booleans diff --git a/src/Dodge/Data/Creature.hs b/src/Dodge/Data/Creature.hs index 5ec07cb10..a54e2dcf6 100644 --- a/src/Dodge/Data/Creature.hs +++ b/src/Dodge/Data/Creature.hs @@ -1,88 +1,99 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Creature - ( module Dodge.Data.Creature - , module Dodge.Data.Creature.Misc - , module Dodge.Data.Creature.State - , module Dodge.Data.Creature.Perception - , module Dodge.Data.Creature.Memory - , module Dodge.Data.Creature.Stance - ) where -import GHC.Generics +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Creature ( + module Dodge.Data.Creature, + module Dodge.Data.Creature.Misc, + module Dodge.Data.Creature.State, + module Dodge.Data.Creature.Perception, + module Dodge.Data.Creature.Memory, + module Dodge.Data.Creature.Stance, +) where + +import Control.Lens import Data.Aeson +import qualified Data.Map.Strict as M +import Dodge.Data.ActionPlan +import Dodge.Data.Creature.Memory import Dodge.Data.Creature.Misc +import Dodge.Data.Creature.Perception +import Dodge.Data.Creature.Stance import Dodge.Data.Creature.State +import Dodge.Data.Hammer import Dodge.Data.Item import Dodge.Data.LoadAction import Dodge.Data.Material -import Dodge.Data.ActionPlan -import Dodge.Data.Hammer -import Dodge.Data.Creature.Perception -import Dodge.Data.Creature.Memory -import Dodge.Data.Creature.Stance +import GHC.Generics import Geometry.Data import qualified IntMapHelp as IM -import qualified Data.Map.Strict as M -import Control.Lens data Creature = Creature - { _crPos :: Point2 - , _crOldPos :: Point2 - , _crVel :: Point2 - , _crDir :: Float - , _crOldDir :: Float - , _crMvDir :: Float - , _crTwist :: Float - , _crType :: CreatureType - , _crID :: Int - , _crRad :: Float - , _crMass :: Float - , _crHP :: Int - , _crMaxHP :: Int - , _crInv :: IM.IntMap Item - , _crInvSel :: InvSel - , _crInvCapacity :: Int - , _crInvLock :: Bool - , _crInvEquipped :: IM.IntMap EquipPosition - , _crEquipment :: M.Map EquipPosition Int - , _crLeftInvSel :: Maybe Int - , _crState :: CreatureState - , _crCorpse :: CreatureCorpse --Creature -> Corpse -> SPic - , _crMaterial :: Material - , _crPastDamage :: Int - , _crStance :: Stance - , _crActionPlan :: ActionPlan - , _crMeleeCooldown :: Int - , _crPerception :: Perception - , _crMemory :: Memory - , _crVocalization :: Vocalization - , _crFaction :: Faction - , _crGroup :: CrGroup - , _crIntention :: Intention - , _crMvType :: CrMvType + { _crPos :: Point2 + , _crOldPos :: Point2 + , _crVel :: Point2 + , _crDir :: Float + , _crOldDir :: Float + , _crMvDir :: Float + , _crTwist :: Float + , _crType :: CreatureType + , _crID :: Int + , _crRad :: Float + , _crMass :: Float + , _crHP :: Int + , _crMaxHP :: Int + , _crInv :: IM.IntMap Item + , _crInvSel :: InvSel + , _crInvCapacity :: Int + , _crInvLock :: Bool + , _crInvEquipped :: IM.IntMap EquipPosition + , _crEquipment :: M.Map EquipPosition Int + , _crLeftInvSel :: Maybe Int + , _crState :: CreatureState + , _crCorpse :: CreatureCorpse --Creature -> Corpse -> SPic + , _crMaterial :: Material + , _crPastDamage :: Int + , _crStance :: Stance + , _crActionPlan :: ActionPlan + , _crMeleeCooldown :: Int + , _crPerception :: Perception + , _crMemory :: Memory + , _crVocalization :: Vocalization + , _crFaction :: Faction + , _crGroup :: CrGroup + , _crIntention :: Intention + , _crMvType :: CrMvType , _crHammerPosition :: HammerPosition - , _crName :: String - , _crStatistics :: CreatureStatistics - , _crCamouflage :: CamouflageStatus + , _crName :: String + , _crStatistics :: CreatureStatistics + , _crCamouflage :: CamouflageStatus } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Creature where + deriving (Eq, Show, Read, Generic) + +instance ToJSON Creature where toEncoding = genericToEncoding defaultOptions -instance FromJSON Creature + +instance FromJSON Creature + data CreatureCorpse = MakeDefaultCorpse - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CreatureCorpse where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON CreatureCorpse where toEncoding = genericToEncoding defaultOptions -instance FromJSON CreatureCorpse + +instance FromJSON CreatureCorpse + data Intention = Intention - { _targetCr :: Maybe Creature - , _mvToPoint :: Maybe Point2 - , _viewPoint :: Maybe Point2 + { _targetCr :: Maybe Creature + , _mvToPoint :: Maybe Point2 + , _viewPoint :: Maybe Point2 } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Intention where + deriving (Eq, Show, Read, Generic) + +instance ToJSON Intention where toEncoding = genericToEncoding defaultOptions -instance FromJSON Intention + +instance FromJSON Intention + makeLenses ''Creature makeLenses ''Intention diff --git a/src/Dodge/Data/Distortion.hs b/src/Dodge/Data/Distortion.hs new file mode 100644 index 000000000..797cc154e --- /dev/null +++ b/src/Dodge/Data/Distortion.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.Distortion where +import Data.Aeson +import Data.Aeson.TH +import Geometry + +data Distortion + = RadialDistortion Point2 Point2 Point2 Float + deriving (Eq,Ord,Show,Read) + +deriveJSON defaultOptions ''Distortion diff --git a/src/Dodge/Data/FloorItem.hs b/src/Dodge/Data/FloorItem.hs index 45f88b403..41a0d1526 100644 --- a/src/Dodge/Data/FloorItem.hs +++ b/src/Dodge/Data/FloorItem.hs @@ -9,7 +9,7 @@ import GHC.Generics import Data.Aeson import Control.Lens data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int} - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq,Show,Read,Generic) instance ToJSON FloorItem where toEncoding = genericToEncoding defaultOptions instance FromJSON FloorItem diff --git a/src/Dodge/Data/HUD.hs b/src/Dodge/Data/HUD.hs index 894b1692e..c71529f75 100644 --- a/src/Dodge/Data/HUD.hs +++ b/src/Dodge/Data/HUD.hs @@ -1,39 +1,51 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.HUD where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Control.Lens -data HUDElement +import Data.Aeson +import GHC.Generics +import Geometry.Data + +data HUDElement = DisplayInventory {_subInventory :: SubInventory} | DisplayCarte - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON HUDElement where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON HUDElement where toEncoding = genericToEncoding defaultOptions -instance FromJSON HUDElement -data SubInventory + +instance FromJSON HUDElement + +data SubInventory = NoSubInventory - | TweakInventory + | TweakInventory {_tweakInvSel :: Maybe Int} | CombineInventory {_combineInvSel :: Maybe Int} | InspectInventory | LockedInventory - | DisplayTerminal {_termID :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON SubInventory where + | DisplayTerminal {_termID :: Int} + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON SubInventory where toEncoding = genericToEncoding defaultOptions -instance FromJSON SubInventory + +instance FromJSON SubInventory + data HUD = HUD - { _hudElement :: HUDElement - , _carteCenter :: Point2 - , _carteZoom :: Float - , _carteRot :: Float + { _hudElement :: HUDElement + , _carteCenter :: Point2 + , _carteZoom :: Float + , _carteRot :: Float } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON HUD where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON HUD where toEncoding = genericToEncoding defaultOptions -instance FromJSON HUD + +instance FromJSON HUD + makeLenses ''HUD makeLenses ''HUDElement makeLenses ''SubInventory diff --git a/src/Dodge/Data/ItEffect.hs b/src/Dodge/Data/ItEffect.hs deleted file mode 100644 index 8b3dc7f8f..000000000 --- a/src/Dodge/Data/ItEffect.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Data.ItEffect where -import GHC.Generics -import Data.Aeson -import Control.Lens --- I believe this is called every frame, not sure when though -data ItEffect - = NoItEffect - | ItInvEffect - {_ieInv :: ItInvEffect --Item -> Creature -> World -> World - ,_ieCounter :: Int - } - | ItRewindEffect - {_ieInv :: ItInvEffect --Item -> Creature -> World -> World --- ,_ieStoredWorlds :: [World] - } - | ItEffect - {_ieInv :: ItInvEffect --Item -> Creature -> World -> World - ,_ieFloor :: ItFloorEffect --Int -> World -> World - ,_ieCounter :: Int - } - | ItInvEffectID - {_ieInv :: ItInvEffect --Item -> Creature -> World -> World - ,_ieMID :: Maybe Int - } -- the duplication of ieMID may cause errors... - | ItInvEffectDrop - { _ieInv :: ItInvEffect --Item -> Creature -> World -> World - , _ieDrop :: ItDropEffect --Item -> Creature -> World -> World - , _ieMID :: Maybe Int - } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItEffect -data ItInvEffect = NoInvEffect - | RewindEffect - | ResetAttachmentEffect - | OnOffHeldEffect ItInvEffect ItInvEffect - | CreateHeldLight - | CreateShieldWall - | RemoveShieldWall - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItInvEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItInvEffect -data ItFloorEffect = NoFloorEffect - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItFloorEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItFloorEffect -data ItDropEffect = NoDropEffect - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItDropEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItDropEffect -makeLenses ''ItEffect diff --git a/src/Dodge/Data/Item.hs b/src/Dodge/Data/Item.hs index 4f3eacd5d..4cc32e945 100644 --- a/src/Dodge/Data/Item.hs +++ b/src/Dodge/Data/Item.hs @@ -1,51 +1,52 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Item - ( module Dodge.Data.Item - , module Dodge.Data.Item.Misc - , module Dodge.Data.Item.Tweak - , module Dodge.Data.Item.Params - , module Dodge.Data.Item.Use - , module Dodge.Data.Item.Consumption - , module Dodge.Data.Item.CurseStatus - , module Dodge.Data.Item.Attachment - ) where -import GHC.Generics -import Data.Aeson +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item ( + module Dodge.Data.Item, + module Dodge.Data.Item.Effect, + module Dodge.Data.Item.Misc, + module Dodge.Data.Item.Tweak, + module Dodge.Data.Item.Params, + module Dodge.Data.Item.Use, + module Dodge.Data.Item.CurseStatus, + module Dodge.Data.Item.Attachment, + module Dodge.Data.Item.Combine, + module Dodge.Data.Item.Targeting, +) where + +import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Item.Combine +import Dodge.Data.Item.Effect +import Dodge.Data.Item.Attachment import Dodge.Data.Item.CurseStatus import Dodge.Data.Item.Misc -import Dodge.Data.Item.Tweak -import Dodge.Data.Item.Consumption -import Dodge.Data.Item.Use import Dodge.Data.Item.Params -import Dodge.Data.ItEffect -import Dodge.Data.Targeting -import Dodge.Combine.Data -import Dodge.Data.Item.Attachment -import Color +import Dodge.Data.Item.Tweak +import Dodge.Data.Item.Use +import Dodge.Data.Item.Targeting + data Item = Item - { _itConsumption :: ItemConsumption - , _itUse :: ItemUse - , _itType :: ItemType + { _itUse :: ItemUse + , _itType :: ItemType , _itAttachment :: ItAttachment - , _itID :: Maybe Int - , _itPos :: ItemPos - , _itIsHeld :: Bool - , _itEffect :: ItEffect - , _itInvSize :: Float - , _itInvColor :: Color - , _itTargeting :: Targeting - , _itDimension :: ItemDimension - , _itCurseStatus :: CurseStatus - , _itTweaks :: ItemTweaks - , _itScope :: Scope - , _itValue :: ItemValue - , _itParams :: ItemParams + , _itID :: Maybe Int + , _itPos :: ItemPos + , _itIsHeld :: Bool + , _itEffect :: ItEffect + , _itInvSize :: Float + , _itInvColor :: Color + , _itTargeting :: Targeting + , _itDimension :: ItemDimension + , _itCurseStatus :: CurseStatus + , _itTweaks :: ItemTweaks + , _itScope :: Scope + , _itValue :: ItemValue + , _itParams :: ItemParams } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Item where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Item + deriving (Eq, Show, Read) + makeLenses ''Item +deriveJSON defaultOptions ''Item diff --git a/src/Dodge/Data/Item/Attachment.hs b/src/Dodge/Data/Item/Attachment.hs index 13e8236df..4e947fae0 100644 --- a/src/Dodge/Data/Item/Attachment.hs +++ b/src/Dodge/Data/Item/Attachment.hs @@ -1,43 +1,44 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Item.Attachment - where -import GHC.Generics -import Data.Aeson -import Geometry.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.Attachment where + import Control.Lens -import qualified Data.Sequence as Seq -data ItAttachment +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + +data ItAttachment = AttachFuse {_atFuseTime :: Int} - | AttachMode {_atMode :: Int} - | AttachCharMode {_atCharMode :: Seq.Seq Char } - | AttachTargetPos { _atTargetPos :: Point2 } - | AttachInt { _atInt :: Int } - | AttachMInt { _atMInt :: Maybe Int } - | AttachFloat { _atFloat :: Float } - | AttachBool { _atBool :: Bool } + | AttachTargetPos {_atTargetPos :: Point2} + | AttachInt {_atInt :: Int} + | AttachMInt {_atMInt :: Maybe Int} + | AttachFloat {_atFloat :: Float} + | AttachBool {_atBool :: Bool} | NoItAttachment - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItAttachment where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItAttachment -data Scope = NoScope - | RemoteScope - {_scopePos :: Point2 -- ^ a camera offset - ,_scopeZoom :: Float - ,_scopeIsCamera :: Bool -- ^ if the camera offset is also the center of vision + deriving (Eq, Ord, Show, Read) + +data Scope + = NoScope + | RemoteScope + { -- | a camera offset + _scopePos :: Point2 + , _scopeZoom :: Float + , -- | if the camera offset is also the center of vision + _scopeIsCamera :: Bool } - | ZoomScope - {_scopePos :: Point2 -- ^ a camera offset - ,_scopeZoomChange :: Int - ,_scopeZoom :: Float - ,_scopeDefaultZoom :: Float - ,_scopeIsCamera :: Bool -- ^ if the camera offset is also the center of vision + | ZoomScope + { -- | a camera offset + _scopePos :: Point2 + , _scopeZoomChange :: Int + , _scopeZoom :: Float + , _scopeDefaultZoom :: Float + , -- | if the camera offset is also the center of vision + _scopeIsCamera :: Bool } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Scope where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Scope + deriving (Eq, Ord, Show, Read) + makeLenses ''ItAttachment makeLenses ''Scope +deriveJSON defaultOptions ''ItAttachment +deriveJSON defaultOptions ''Scope diff --git a/src/Dodge/Combine/Data.hs b/src/Dodge/Data/Item/Combine.hs similarity index 52% rename from src/Dodge/Combine/Data.hs rename to src/Dodge/Data/Item/Combine.hs index 8eaf0fbdc..c05b811fc 100644 --- a/src/Dodge/Combine/Data.hs +++ b/src/Dodge/Data/Item/Combine.hs @@ -1,28 +1,25 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} -module Dodge.Combine.Data - where -import GHC.Generics -import Data.Aeson -import Dodge.Data.Equipment.Misc -import Dodge.Data.ItemAmount + +module Dodge.Data.Item.Combine where + +import Dodge.Data.Item.Use.Consumption import Control.Lens +import Data.Aeson +import Data.Aeson.TH import qualified Data.Map.Strict as M --- this should probably store loaded ammo -data ItemType = ItemType - {_iyBase :: ItemBaseType - ,_iyModules :: M.Map ModuleSlot ItemModuleType - ,_iyStack :: Stack +import Dodge.Data.Equipment.Misc + +data ItemType = ItemType + { _iyBase :: ItemBaseType + , _iyModules :: M.Map ModuleSlot ItemModuleType + , _iyStack :: Stack } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItemType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItemType -data Stack = NoStack | Stack IcAmount - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Stack where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Stack + deriving (Eq, Ord, Show, Read) + +data Stack = NoStack | Stack ItAmount + deriving (Eq, Ord, Show, Read) + data CraftType = PIPE | TUBE @@ -47,7 +44,7 @@ data CraftType | MICROCHIP | AIUNIT | CAMERA - | MINIDISPLAY -- visual display unit + | MINIDISPLAY -- visual display unit | LED | NAILBOX | IRONBAR @@ -59,8 +56,6 @@ data CraftType | BATTERY | FUELCELL | PORTABLEFUSION - -- Modules - -- bullet | INCENDIARYMODULE | STATICMODULE | CONCUSSMODULE @@ -68,38 +63,24 @@ data CraftType | FLASHMODULE | BOUNCEMODULE | PENMODULE - -- | TELEPORTMODULE | TIMEMODULE | SIZEMODULE | GRAVITYMODULE - deriving (Eq,Ord,Show,Enum,Read,Generic) -instance ToJSON CraftType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CraftType --- TODO make this an enum somehow...? + deriving (Eq, Ord, Show, Enum, Read) + data ItemBaseType - = NOTDEFINED - | EFFGUN String - | AUTOEFFGUN String - -- Weapons - | HELD {_ibtHeld :: HeldItemType} + = HELD {_ibtHeld :: HeldItemType} | LEFT {_ibtLeft :: LeftItemType} | EQUIP {_ibtEquip :: EquipItemType} --- | GRENADE --- | REMOTEBOMB - -- Utility items - -- Equipment - -- - | KEYCARD Int - -- - | MEDKIT Int + | Consumable {_ibtConsumable :: ConsumableItemType} | CRAFT CraftType - -- - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItemBaseType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItemBaseType + deriving (Eq, Ord, Show, Read) + +data ConsumableItemType + = MEDKIT Int + deriving (Eq, Ord, Show, Read) + data EquipItemType = MAGSHIELD | FLAMESHIELD @@ -115,10 +96,8 @@ data EquipItemType | JUMPLEGS | JETPACK | AUTODETECTOR Detector - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON EquipItemType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON EquipItemType + deriving (Eq, Ord, Show, Read) + data LeftItemType = BOOSTER | REWINDER @@ -126,10 +105,8 @@ data LeftItemType | BLINKERUNSAFE | SHRINKER | SPAWNER - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LeftItemType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LeftItemType + deriving (Eq, Ord, Show, Read) + data HeldItemType = BANGSTICK {_xNum :: Int} | PISTOL @@ -141,18 +118,17 @@ data HeldItemType | BANGCONE | BLUNDERBUSS | GRAPECANNON {_xNum :: Int} --- | GRENADELAUNCHER Int -- number of chambers that can be reloaded --- | MORTARCONE / HANDMORTAR --- | MINIGUN - | MINIGUNX {_xNum :: Int} + | -- | GRENADELAUNCHER Int -- number of chambers that can be reloaded + -- | MORTARCONE / HANDMORTAR + MINIGUNX {_xNum :: Int} | VOLLEYGUN {_xNum :: Int} | RIFLE | REPEATER | AUTORIFLE | BURSTRIFLE --- | FASTBURSTRIFLE --- | COMPLETEBURSTRIFLE - | BANGROD + | -- | FASTBURSTRIFLE + -- | COMPLETEBURSTRIFLE + BANGROD | ELEPHANTGUN | AMR | AUTOAMR @@ -167,34 +143,31 @@ data HeldItemType | TESLAGUN | LASGUN | LASCIRCLE --- | LASPULSE - | DUALBEAM --- | LASGUNSWING - -- | LASGUNSWAY --- | LASGUNWIDEPULSE - | LASWIDE {_xNum :: Int} - -- | LASGUNFOCUS Int - -- | SONICGUN - | TRACTORGUN + | -- | LASPULSE + DUALBEAM + | -- | LASGUNSWING + + -- | LASGUNSWAY + -- | LASGUNWIDEPULSE + LASWIDE {_xNum :: Int} + | -- | LASGUNFOCUS Int + -- | SONICGUN + TRACTORGUN | LAUNCHER | LAUNCHERX {_xNum :: Int} --- | TRACKINGLAUNCHER - | REMOTELAUNCHER + | -- | TRACKINGLAUNCHER + REMOTELAUNCHER | POISONSPRAYER | DRONELAUNCHER - | SHATTERGUN - | FORCEFIELDGUN - | HELDDETECTOR Detector | TORCH | FLATSHIELD - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON HeldItemType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON HeldItemType -data ItemModuleType + | KEYCARD Int + deriving (Eq, Ord, Show, Read) + +data ItemModuleType = EMPTYMODULE | DRUMMAG | BELTMAG @@ -204,7 +177,7 @@ data ItemModuleType | PENBUL | STATICBUL | CONCUSBUL - | TARGCR + | TARGCR | TARGLAS | TARGPOS | MAGNETTRAJ @@ -217,18 +190,14 @@ data ItemModuleType | LAUNCHHOME | EXTRABATTERY | ATTACHTORCH - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItemModuleType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItemModuleType + deriving (Eq, Ord, Show, Read) + data Detector = ITEMDETECTOR | CREATUREDETECTOR | WALLDETECTOR - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Detector where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Detector + deriving (Eq, Ord, Show, Read) + data ModuleSlot = ModBullet | ModBulletSpawn @@ -241,12 +210,23 @@ data ModuleSlot | ModTeleport | ModDualBeam | ModHeldAttach - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ModuleSlot where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ModuleSlot + deriving (Eq, Ord, Show, Read) + instance ToJSONKey ModuleSlot + instance FromJSONKey ModuleSlot + +deriveJSON defaultOptions ''ItemType +deriveJSON defaultOptions ''Stack +deriveJSON defaultOptions ''CraftType +deriveJSON defaultOptions ''ItemBaseType +deriveJSON defaultOptions ''ConsumableItemType +deriveJSON defaultOptions ''EquipItemType +deriveJSON defaultOptions ''LeftItemType +deriveJSON defaultOptions ''HeldItemType +deriveJSON defaultOptions ''ItemModuleType +deriveJSON defaultOptions ''Detector +deriveJSON defaultOptions ''ModuleSlot makeLenses ''ItemType makeLenses ''ItemBaseType makeLenses ''HeldItemType diff --git a/src/Dodge/Data/Item/Consumption.hs b/src/Dodge/Data/Item/Consumption.hs deleted file mode 100644 index 468e5a399..000000000 --- a/src/Dodge/Data/Item/Consumption.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Data.Item.Consumption where -import GHC.Generics -import Data.Aeson -import Control.Lens -import Dodge.Data.Ammo -import Dodge.Data.LoadAction -import Dodge.Data.ItemAmount -data ItemConsumption - = LoadableAmmo - { _laAmmoType :: AmmoType - , _laMax :: Int - , _laLoaded :: Int - , _laPrimed :: Bool - , _laCycle :: [LoadAction] - , _laProgress :: Maybe [LoadAction] - } - | AutoRecharging - { _arLoaded :: Int - , _arMax :: Int - , _arTime :: Int - , _arProgress :: Int - } - | ChargeableAmmo - { _wpMaxCharge :: Int - , _wpCharge :: Int - } - | ItemItselfConsumable - { _icAmount :: IcAmount - } - | NoConsumption - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItemConsumption where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItemConsumption -makeLenses ''ItemConsumption diff --git a/src/Dodge/Data/Item/Effect.hs b/src/Dodge/Data/Item/Effect.hs new file mode 100644 index 000000000..d5dc4622d --- /dev/null +++ b/src/Dodge/Data/Item/Effect.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.Effect where + +import Control.Lens +import Data.Aeson +import Data.Aeson.TH + +data ItEffect + = NoItEffect + | ItInvEffect + { _ieInv :: ItInvEffect --Item -> Creature -> World -> World + , _ieCounter :: Int + } + | ItRewindEffect + { _ieInv :: ItInvEffect --Item -> Creature -> World -> World + } + | ItEffect + { _ieInv :: ItInvEffect --Item -> Creature -> World -> World + , _ieFloor :: ItFloorEffect --Int -> World -> World + , _ieCounter :: Int + } + | ItInvEffectID + { _ieInv :: ItInvEffect --Item -> Creature -> World -> World + , _ieMID :: Maybe Int + } -- the duplication of ieMID may cause errors... + | ItInvEffectDrop + { _ieInv :: ItInvEffect --Item -> Creature -> World -> World + , _ieDrop :: ItDropEffect --Item -> Creature -> World -> World + , _ieMID :: Maybe Int + } + deriving (Eq, Ord, Show, Read) + +data ItInvEffect + = NoInvEffect + | RewindEffect + | ResetAttachmentEffect + | OnOffHeldEffect ItInvEffect ItInvEffect + | CreateHeldLight + | CreateShieldWall + | RemoveShieldWall + deriving (Eq, Ord, Show, Read) + +data ItFloorEffect = NoFloorEffect + deriving (Eq, Ord, Show, Read) + +data ItDropEffect = NoDropEffect + deriving (Eq, Ord, Show, Read) + +makeLenses ''ItEffect +deriveJSON defaultOptions ''ItEffect +deriveJSON defaultOptions ''ItInvEffect +deriveJSON defaultOptions ''ItFloorEffect +deriveJSON defaultOptions ''ItDropEffect diff --git a/src/Dodge/Data/Item/HeldScroll.hs b/src/Dodge/Data/Item/HeldScroll.hs index 2a56f3390..4ab4040f0 100644 --- a/src/Dodge/Data/Item/HeldScroll.hs +++ b/src/Dodge/Data/Item/HeldScroll.hs @@ -1,10 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Item.HeldScroll where -import GHC.Generics + +import Control.Lens import Data.Aeson -data HeldScroll = HeldScrollDoNothing | HeldScrollZoom | HeldScrollCharMode - deriving (Eq,Ord,Enum,Bounded,Show,Read,Generic) -instance ToJSON HeldScroll where - toEncoding = genericToEncoding defaultOptions -instance FromJSON HeldScroll +import Data.Aeson.TH +import qualified Data.Sequence as Seq + +data HeldScroll + = HeldScrollDoNothing + | HeldScrollZoom + | HeldScrollCharMode + {_hsCharMode :: Seq.Seq Char} + | HeldScrollInt + { _hsInt :: Int + , _hsMaxInt :: Int + } + deriving (Eq, Ord, Show, Read) + +makeLenses ''HeldScroll +deriveJSON defaultOptions ''HeldScroll diff --git a/src/Dodge/Data/Item/HeldUse.hs b/src/Dodge/Data/Item/HeldUse.hs index f820e1214..554566b79 100644 --- a/src/Dodge/Data/Item/HeldUse.hs +++ b/src/Dodge/Data/Item/HeldUse.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} module Dodge.Data.Item.HeldUse where import Data.Aeson -import Dodge.Combine.Data +import Data.Aeson.TH import Dodge.Data.CamouflageStatus -import GHC.Generics +import Dodge.Data.Item.Combine data HeldUse = HeldDoNothing @@ -24,22 +24,12 @@ data HeldUse | HeldTractor | HeldForceField | HeldShatter - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON HeldUse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON HeldUse + deriving (Eq, Ord, Show, Read) data Cuse = CDoNothing | CHeal Int - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Cuse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Cuse + deriving (Eq, Ord, Show, Read) data Euse = EDoNothing @@ -50,12 +40,7 @@ data Euse | ECamouflage CamouflageStatus | EonWristShield | EoffWristShield - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Euse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Euse + deriving (Eq, Ord, Show, Read) data Luse = LDoNothing @@ -64,12 +49,7 @@ data Luse | LBlink | LUnsafeBlink | LBoost - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Luse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Luse + deriving (Eq, Ord, Show, Read) data HeldMod = HeldModNothing @@ -107,9 +87,10 @@ data HeldMod | RevolverXMod | RevolverXRepeatMod | BangConeMod - deriving (Eq, Ord, Show, Read, Generic) + deriving (Eq, Ord, Show, Read) -instance ToJSON HeldMod where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON HeldMod +deriveJSON defaultOptions ''Cuse +deriveJSON defaultOptions ''HeldMod +deriveJSON defaultOptions ''Euse +deriveJSON defaultOptions ''HeldUse +deriveJSON defaultOptions ''Luse diff --git a/src/Dodge/Data/Item/Params.hs b/src/Dodge/Data/Item/Params.hs index 23742e4eb..a6599a0b1 100644 --- a/src/Dodge/Data/Item/Params.hs +++ b/src/Dodge/Data/Item/Params.hs @@ -1,22 +1,24 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Item.Params where -import GHC.Generics -import Data.Aeson -import Dodge.Data.Beam -import Dodge.Data.ArcStep -import Geometry.Data + import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.ArcStep +import Dodge.Data.Beam +import Geometry.Data + data ItemParams = NoParams | ShellLauncher - { _shellSpinDrag :: Int - , _shellSpinAmount :: Int + { _shellSpinDrag :: Int + , _shellSpinAmount :: Int , _shellThrustDelay :: Int } - | Refracting + | Refracting { _phaseV :: Float , _lasColor :: Color , _lasColor2 :: Color @@ -31,77 +33,83 @@ data ItemParams , _lasDamage :: Int , _lasBeam :: BeamType , _subParams :: Maybe ItemParams - , _dbGap :: Float + , _dbGap :: Float } - | Attracting {_attractionPower :: Point2} + | Attracting {_attractionPower :: Point2} | BulletShooter - { _muzVel :: Float - , _rifling :: Float - , _bore :: Float + { _muzVel :: Float + , _rifling :: Float + , _bore :: Float , _gunBarrels :: GunBarrels - , _recoil :: Float - , _torqueAfter :: Float + , _recoil :: Float + , _torqueAfter :: Float , _randomOffset :: Float } - | Sprayer { _sprayNozzles :: [Nozzle] } + | Sprayer {_sprayNozzles :: [Nozzle]} | AngleWalk { _maxWalkAngle :: Float , _currentWalkAngle :: Float , _walkSpeed :: Float } - | Arcing - { _currentArc :: Maybe [ArcStep] + | Arcing + { _currentArc :: Maybe [ArcStep] , _arcSize :: Float , _arcNumber :: Int , _newArcStep :: NextArcStep --ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep) , _previousArcEffect :: PreviousArcEffect } | ParamMID {_paramMID :: Maybe Int} - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItemParams where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItemParams + | BoostPropIX {_boostPropIX :: Maybe Int} + deriving (Eq, Ord, Show, Read) + + + data PreviousArcEffect = NoPreviousArcEffect | PerturbTillBreakPreviousArc - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON PreviousArcEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON PreviousArcEffect + deriving (Eq, Ord, Show, Read) + + + data GunBarrels = MultiBarrel - { _brlSpread :: BarrelSpread - , _brlNum :: Int + { _brlSpread :: BarrelSpread + , _brlNum :: Int , _brlInaccuracy :: Float } | RotBarrel - { _brlNum :: Int + { _brlNum :: Int , _brlInaccuracy :: Float } - | SingleBarrel {_brlInaccuracy :: Float} - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON GunBarrels where - toEncoding = genericToEncoding defaultOptions -instance FromJSON GunBarrels + | SingleBarrel {_brlInaccuracy :: Float} + deriving (Eq, Ord, Show, Read) + + + data Nozzle = Nozzle { _nzPressure :: Float , _nzDir :: Float , _nzMaxWalkAngle :: Float , _nzCurrentWalkAngle :: Float - , _nzWalkSpeed :: Float - , _nzLength :: Float + , _nzWalkSpeed :: Float + , _nzLength :: Float } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Nozzle where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Nozzle + deriving (Eq, Ord, Show, Read) + + + data BarrelSpread = AlignedBarrels - | SpreadBarrels {_spreadAngle :: Float} + | SpreadBarrels {_spreadAngle :: Float} | RotatingBarrels {_rotatingBarrelInaccuracy :: Float} - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BarrelSpread where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BarrelSpread + deriving (Eq, Ord, Show, Read) + + + makeLenses ''BarrelSpread makeLenses ''ItemParams makeLenses ''Nozzle makeLenses ''GunBarrels +deriveJSON defaultOptions ''ItemParams +deriveJSON defaultOptions ''PreviousArcEffect +deriveJSON defaultOptions ''GunBarrels +deriveJSON defaultOptions ''Nozzle +deriveJSON defaultOptions ''BarrelSpread diff --git a/src/Dodge/Data/Item/Targeting.hs b/src/Dodge/Data/Item/Targeting.hs new file mode 100644 index 000000000..fc43a4e35 --- /dev/null +++ b/src/Dodge/Data/Item/Targeting.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.Targeting where + +import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + +data Targeting + = NoTargeting + | Targeting + { _tgPos :: Maybe Point2 + , _tgUpdate :: TargetUpdate --Item -> Creature -> World -> Targeting -> (World, Targeting) + , _tgDraw :: TargetDraw --Item -> Creature -> Configuration -> World -> Picture + , _tgID :: Maybe Int + , _tgActive :: Bool + } + deriving (Eq, Ord, Show, Read) + +data TargetUpdate + = NoTargetUpdate + | TargetLaserUpdate + | TargetRBPressUpdate + | TargetRBCreatureUpdate + | TargetCursorUpdate + deriving (Eq, Ord, Show, Read) + +data TargetDraw + = NoTargetDraw + | TargetDistanceDraw + | SimpleDrawTarget + | TargetRBCreatureDraw + deriving (Eq, Ord, Show, Read) + +makeLenses ''Targeting +deriveJSON defaultOptions ''Targeting +deriveJSON defaultOptions ''TargetUpdate +deriveJSON defaultOptions ''TargetDraw diff --git a/src/Dodge/Data/Item/Tweak.hs b/src/Dodge/Data/Item/Tweak.hs index d15e71ef4..0e771b07d 100644 --- a/src/Dodge/Data/Item/Tweak.hs +++ b/src/Dodge/Data/Item/Tweak.hs @@ -10,7 +10,6 @@ data ItemTweaks = NoTweaks | Tweakable { _tweakParams :: IM.IntMap TweakParam - , _tweakSel :: Int } deriving (Eq,Ord,Show,Read,Generic) instance ToJSON ItemTweaks where diff --git a/src/Dodge/Data/Item/Use.hs b/src/Dodge/Data/Item/Use.hs index bf268adb0..1a399f6a0 100644 --- a/src/Dodge/Data/Item/Use.hs +++ b/src/Dodge/Data/Item/Use.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -8,16 +7,18 @@ module Dodge.Data.Item.Use ( module Dodge.Data.Item.HeldUse, module Dodge.Data.Item.HeldScroll, module Dodge.Data.Item.UseDelay, + module Dodge.Data.Item.Use.Consumption, ) where import Control.Lens import Data.Aeson +import Data.Aeson.TH import Dodge.Data.Hammer import Dodge.Data.Item.HeldScroll import Dodge.Data.Item.HeldUse +import Dodge.Data.Item.Use.Consumption import Dodge.Data.Item.Use.Equipment import Dodge.Data.Item.UseDelay -import GHC.Generics data ItemUse = RightUse @@ -27,24 +28,26 @@ data ItemUse , _useHammer :: HammerPosition , _useAim :: AimParams , _heldScroll :: HeldScroll + , _heldConsumption :: HeldConsumption } | LeftUse { _lUse :: Luse , _useDelay :: UseDelay , _useHammer :: HammerPosition , _eqEq :: Equipment + , _leftConsumption :: LeftConsumption } | ConsumeUse { _cUse :: Cuse + , _useAmount :: ItAmount } | EquipUse { _eqEq :: Equipment } - | NoUse - deriving (Eq, Ord, Show, Read, Generic) -instance ToJSON ItemUse where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItemUse + | CraftUse + {_useAmount :: ItAmount} + deriving (Eq, Show, Read) + data AimParams = AimParams { _aimWeight :: Int , _aimRange :: Float @@ -53,28 +56,26 @@ data AimParams = AimParams , _aimHandlePos :: Float , _aimMuzPos :: Float } - deriving (Eq, Ord, Show, Read, Generic) -instance ToJSON AimParams where - toEncoding = genericToEncoding defaultOptions -instance FromJSON AimParams + deriving (Eq, Ord, Show, Read) + data AimStance = TwoHandTwist | TwoHandFlat | OneHand | LeaveHolstered - deriving (Eq, Show, Ord, Enum, Read, Generic) -instance ToJSON AimStance where - toEncoding = genericToEncoding defaultOptions -instance FromJSON AimStance + deriving (Eq, Show, Ord, Enum, Read) + data ItZoom = ItZoom { _itZoomMax :: Float , _itZoomMin :: Float , _itZoomFac :: Float } - deriving (Eq, Ord, Show, Read, Generic) -instance ToJSON ItZoom where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItZoom + deriving (Eq, Ord, Show, Read) + makeLenses ''ItemUse makeLenses ''AimParams makeLenses ''ItZoom +deriveJSON defaultOptions ''ItemUse +deriveJSON defaultOptions ''AimParams +deriveJSON defaultOptions ''AimStance +deriveJSON defaultOptions ''ItZoom diff --git a/src/Dodge/Data/Item/Use/Consumption.hs b/src/Dodge/Data/Item/Use/Consumption.hs new file mode 100644 index 000000000..83bec6c7b --- /dev/null +++ b/src/Dodge/Data/Item/Use/Consumption.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.Use.Consumption where + +import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Ammo +import Dodge.Data.LoadAction + +data HeldConsumption + = LoadableAmmo + { _laAmmoType :: AmmoType + , _laMax :: Int + , _laLoaded :: Int + , _laPrimed :: Bool + , _laCycle :: [LoadAction] + , _laProgress :: Maybe [LoadAction] + } + | NoConsumption + deriving (Eq, Show, Read) + +data LeftConsumption + = AutoRecharging + { _arLoaded :: Int + , _arMax :: Int + , _arTime :: Int + , _arProgress :: Int + } + | ChargeableAmmo + { _wpMaxCharge :: Int + , _wpCharge :: Int + } + deriving (Eq, Show, Read) + +newtype ItAmount = ItAmount {_getItAmount :: Int} + deriving (Eq, Ord, Read, Show, Num, Real, Enum, Integral) + +makeLenses ''HeldConsumption +makeLenses ''LeftConsumption +makeLenses ''ItAmount +deriveJSON defaultOptions ''HeldConsumption +deriveJSON defaultOptions ''LeftConsumption +deriveJSON defaultOptions ''ItAmount diff --git a/src/Dodge/Data/ItemAmount.hs b/src/Dodge/Data/ItemAmount.hs deleted file mode 100644 index e402d4b5c..000000000 --- a/src/Dodge/Data/ItemAmount.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Dodge.Data.ItemAmount where -import GHC.Generics -import Data.Aeson -newtype IcAmount = IcAmount {_toInt :: Int} - deriving (Eq,Ord,Num,Integral,Real,Enum,Read,Show,Generic) -instance ToJSON IcAmount where - toEncoding = genericToEncoding defaultOptions -instance FromJSON IcAmount diff --git a/src/Dodge/Data/Machine.hs b/src/Dodge/Data/Machine.hs index db384b56b..3688ac872 100644 --- a/src/Dodge/Data/Machine.hs +++ b/src/Dodge/Data/Machine.hs @@ -1,61 +1,73 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Machine - where -import GHC.Generics -import Data.Aeson -import Dodge.Data.GenParams -import Dodge.Data.Item -import Sound.Data -import Dodge.Data.Object -import Dodge.Data.Damage -import Dodge.Data.Sensor -import Geometry.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Machine where + import Color -import Dodge.Data.Material +import Control.Lens +import Data.Aeson import qualified Data.IntSet as IS import qualified Data.Map.Strict as M -import Control.Lens -data MachineDraw = MachineDrawMempty +import Dodge.Data.Damage +import Dodge.Data.GenParams +import Dodge.Data.Item +import Dodge.Data.Material +import Dodge.Data.Object +import Dodge.Data.Sensor +import GHC.Generics +import Geometry.Data +import Sound.Data + +data MachineDraw + = MachineDrawMempty | MachineDrawTerminal | MachineDrawTurret - | MachineDrawDamageSensor Float (PaletteColor,DecorationShape) - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON MachineDraw where + | MachineDrawDamageSensor Float (PaletteColor, DecorationShape) + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON MachineDraw where toEncoding = genericToEncoding defaultOptions -instance FromJSON MachineDraw + +instance FromJSON MachineDraw + data Machine = Machine - { _mcID :: Int - , _mcWallIDs :: IS.IntSet - , _mcDraw :: MachineDraw --Machine -> SPic + { _mcID :: Int + , _mcWallIDs :: IS.IntSet + , _mcDraw :: MachineDraw --Machine -> SPic , _mcMaterial :: Material - , _mcPos :: Point2 - , _mcDir :: Float - , _mcColor :: Color - , _mcHP :: Int + , _mcPos :: Point2 + , _mcDir :: Float + , _mcColor :: Color + , _mcHP :: Int , _mcSensor :: Sensor , _mcDamage :: [Damage] - , _mcType :: MachineType + , _mcType :: MachineType , _mcMounts :: M.Map ObjectType Int - , _mcName :: String - , _mcCloseSound :: Maybe SoundID + , _mcName :: String + , _mcCloseSound :: Maybe SoundID } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Machine where + deriving (Eq, Show, Read, Generic) + +instance ToJSON Machine where toEncoding = genericToEncoding defaultOptions -instance FromJSON Machine -data MachineType + +instance FromJSON Machine + +data MachineType = StaticMachine | Turret - { _tuWeapon :: Item - , _tuTurnSpeed :: Float - , _tuFireTime :: Int - , _tuMCrID :: Maybe Int + { _tuWeapon :: Item + , _tuTurnSpeed :: Float + , _tuFireTime :: Int + , _tuMCrID :: Maybe Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON MachineType where + deriving (Eq, Show, Read, Generic) + +instance ToJSON MachineType where toEncoding = genericToEncoding defaultOptions -instance FromJSON MachineType + +instance FromJSON MachineType + makeLenses ''Machine makeLenses ''MachineType diff --git a/src/Dodge/RoomCluster/Data.hs b/src/Dodge/Data/RoomCluster.hs similarity index 82% rename from src/Dodge/RoomCluster/Data.hs rename to src/Dodge/Data/RoomCluster.hs index d40f796df..f42813fe5 100644 --- a/src/Dodge/RoomCluster/Data.hs +++ b/src/Dodge/Data/RoomCluster.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.RoomCluster.Data where -import qualified Data.Set as S +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.RoomCluster where + import Control.Lens +import qualified Data.Set as S data ClusterStatus = ClusterStatus { _csName :: String @@ -10,6 +12,6 @@ data ClusterStatus = ClusterStatus } data ClusterLink = OnwardCluster | SideCluster | LabelCluster Int - deriving (Ord,Eq,Show) + deriving (Ord, Eq, Show) makeLenses ''ClusterStatus diff --git a/src/Dodge/Data/Sensor.hs b/src/Dodge/Data/Sensor.hs index 1aacafd25..d18e9fe49 100644 --- a/src/Dodge/Data/Sensor.hs +++ b/src/Dodge/Data/Sensor.hs @@ -1,40 +1,40 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Sensor where -import GHC.Generics -import Data.Aeson -import Dodge.Combine.Data -import Dodge.Data.Damage.Type + import Control.Lens -data Sensor = NoSensor +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Item.Combine +import Dodge.Data.Damage.Type + +data Sensor + = NoSensor | DamageSensor { _sensToggle :: Bool , _sensAmount :: Int - , _sensType :: DamageType + , _sensType :: DamageType } | ProximitySensor - { _proxStatus :: CloseToggle + { _proxStatus :: CloseToggle , _proxDist :: Float , _proxRequirement :: ProximityRequirement , _sensToggle :: Bool } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Sensor where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Sensor + deriving (Eq, Ord, Show, Read) + data ProximityRequirement = RequireHealth {_proxReqMinHealth :: Int} | RequireEquipment {_proxReqEquipment :: ItemBaseType} | RequireImpossible - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ProximityRequirement where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ProximityRequirement + deriving (Eq, Ord, Show, Read) + data CloseToggle = NotClose | IsClose - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CloseToggle where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CloseToggle + deriving (Eq, Ord, Show, Read) + makeLenses ''Sensor makeLenses ''ProximityRequirement +deriveJSON defaultOptions ''Sensor +deriveJSON defaultOptions ''ProximityRequirement +deriveJSON defaultOptions ''CloseToggle diff --git a/src/Dodge/Data/Targeting.hs b/src/Dodge/Data/Targeting.hs deleted file mode 100644 index dec688ae4..000000000 --- a/src/Dodge/Data/Targeting.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Data.Targeting where -import GHC.Generics -import Data.Aeson -import Geometry.Data -import Control.Lens -data Targeting - = NoTargeting - | Targeting - { _tgPos :: Maybe Point2 - , _tgUpdate :: TargetUpdate --Item -> Creature -> World -> Targeting -> (World, Targeting) - , _tgDraw :: TargetDraw --Item -> Creature -> Configuration -> World -> Picture - , _tgID :: Maybe Int - , _tgActive :: Bool - } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Targeting where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Targeting -data TargetUpdate = NoTargetUpdate - | TargetLaserUpdate - | TargetRBPressUpdate - | TargetRBCreatureUpdate - | TargetCursorUpdate - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TargetUpdate where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TargetUpdate -data TargetDraw = NoTargetDraw - | TargetDistanceDraw - | SimpleDrawTarget - | TargetRBCreatureDraw - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TargetDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TargetDraw -makeLenses ''Targeting diff --git a/src/Dodge/Data/Terminal.hs b/src/Dodge/Data/Terminal.hs index 47a18eeb3..1b0d869d4 100644 --- a/src/Dodge/Data/Terminal.hs +++ b/src/Dodge/Data/Terminal.hs @@ -1,134 +1,176 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Terminal - where -import GHC.Generics -import Data.Aeson -import Dodge.Data.WorldEffect +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Terminal where + import Color import Control.Lens -import qualified Data.Text as T +import Data.Aeson import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Dodge.Data.WorldEffect +import GHC.Generics + data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalStatus where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON TerminalStatus where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalStatus + +instance FromJSON TerminalStatus + data TerminalInput = TerminalInput - { _tiText :: T.Text - , _tiFocus :: Bool - , _tiSel :: (Int,Int) + { _tiText :: T.Text + , _tiFocus :: Bool + , _tiSel :: (Int, Int) } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalInput where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON TerminalInput where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalInput -data TerminalBootProgram = TerminalBootMempty + +instance FromJSON TerminalInput + +data TerminalBootProgram + = TerminalBootMempty | TerminalBootLines [TerminalLine] - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalBootProgram where + deriving (Eq, Show, Read, Generic) + +instance ToJSON TerminalBootProgram where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalBootProgram + +instance FromJSON TerminalBootProgram + data Terminal = Terminal - { _tmID :: Int - , _tmBootProgram :: TerminalBootProgram -- Terminal -> World -> [TerminalLine] - , _tmButtonID :: Int - , _tmMachineID :: Int - , _tmName :: String - , _tmDisplayedLines :: [(String,Color)] - , _tmFutureLines :: [TerminalLine] - , _tmMaxLines :: Int - , _tmTitle :: String - , _tmInput :: TerminalInput + { _tmID :: Int + , _tmBootProgram :: TerminalBootProgram -- Terminal -> World -> [TerminalLine] + , _tmButtonID :: Int + , _tmMachineID :: Int + , _tmName :: String + , _tmDisplayedLines :: [(String, Color)] + , _tmFutureLines :: [TerminalLine] + , _tmMaxLines :: Int + , _tmTitle :: String + , _tmInput :: TerminalInput , _tmScrollCommands :: [TerminalCommand] - , _tmWriteCommands :: [TerminalCommand] - , _tmDeathEffect :: TmWdWd -- Terminal -> World -> World + , _tmWriteCommands :: [TerminalCommand] + , _tmDeathEffect :: TmWdWd -- Terminal -> World -> World , _tmStatus :: TerminalStatus , _tmCommandHistory :: [String] , _tmToggles :: M.Map String TerminalToggle } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Terminal where + deriving (Eq, Show, Read, Generic) + +instance ToJSON Terminal where toEncoding = genericToEncoding defaultOptions -instance FromJSON Terminal + +instance FromJSON Terminal + data TerminalLineString = TerminalLineConst String Color - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalLineString where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON TerminalLineString where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalLineString -data TmTm = TmId + +instance FromJSON TerminalLineString + +data TmTm + = TmId | TmTmClearDisplayedLines | TmTmSetStatus TerminalStatus - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TmTm where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON TmTm where toEncoding = genericToEncoding defaultOptions -instance FromJSON TmTm + +instance FromJSON TmTm + data TerminalLine = TerminalLineDisplay - {_tlPause :: Int - ,_tlString :: TerminalLineString -- World -> (String, Color) + { _tlPause :: Int + , _tlString :: TerminalLineString -- World -> (String, Color) } | TerminalLineTerminalEffect - {_tlPause :: Int - ,_tlTermEffect :: TmTm -- Terminal -> Terminal + { _tlPause :: Int + , _tlTermEffect :: TmTm -- Terminal -> Terminal } | TerminalLineEffect - {_tlPause :: Int - ,_tlEffect :: TmWdWd --Terminal -> World -> World + { _tlPause :: Int + , _tlEffect :: TmWdWd --Terminal -> World -> World } - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Show, Read, Generic) + instance ToJSON TerminalLine where toEncoding = genericToEncoding defaultOptions + instance FromJSON TerminalLine + data TerminalToggle = TerminalToggle { _ttTriggerID :: Int , _ttDeathEffect :: BlBl } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalToggle where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON TerminalToggle where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalToggle -data BlBl = BlNegate + +instance FromJSON TerminalToggle + +data BlBl + = BlNegate | BlConst Bool | BlId - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BlBl where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON BlBl where toEncoding = genericToEncoding defaultOptions -instance FromJSON BlBl + +instance FromJSON BlBl + data EffectArguments = NoArguments {_cmdEffect :: [TerminalLine]} - | OneArgument - {_argType :: String - ,_argList :: M.Map String [TerminalLine] + | OneArgument + { _argType :: String + , _argList :: M.Map String [TerminalLine] } - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Show, Read, Generic) + instance ToJSON EffectArguments where toEncoding = genericToEncoding defaultOptions + instance FromJSON EffectArguments -data TerminalCommandEffect = TerminalCommandArguments EffectArguments + +data TerminalCommandEffect + = TerminalCommandArguments EffectArguments | TerminalCommandEffectDamageCoding | TerminalCommandEffectSensorParameter - | TerminalCommandEffectLinkedObject + | TerminalCommandEffectLinkedObject | TerminalCommandEffectHelp | TerminalCommandEffectNoArgumentsStr String | TerminalCommandEffectCommands | TerminalCommandEffectSingleCommand WdWd [String] | TerminalCommandEffectNone - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalCommandEffect where + deriving (Eq, Show, Read, Generic) + +instance ToJSON TerminalCommandEffect where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalCommandEffect + +instance FromJSON TerminalCommandEffect + data TerminalCommand = TerminalCommand { _tcString :: String - , _tcAlias :: [String] - , _tcHelp :: String + , _tcAlias :: [String] + , _tcHelp :: String , _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TerminalCommand where + deriving (Eq, Show, Read, Generic) + +instance ToJSON TerminalCommand where toEncoding = genericToEncoding defaultOptions -instance FromJSON TerminalCommand + +instance FromJSON TerminalCommand + makeLenses ''TerminalInput makeLenses ''Terminal makeLenses ''TerminalLine diff --git a/src/Dodge/Data/WorldEffect.hs b/src/Dodge/Data/WorldEffect.hs index d0044645c..168763aea 100644 --- a/src/Dodge/Data/WorldEffect.hs +++ b/src/Dodge/Data/WorldEffect.hs @@ -1,24 +1,31 @@ +{-# LANGUAGE DeriveGeneric #-} --{-# LANGUAGE DeriveGeneric #-} --{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} -module Dodge.Data.WorldEffect where -import Dodge.Data.Item -import Data.Aeson -import GHC.Generics -import Dodge.Data.CreatureEffect -import Sound.Data -import Geometry.Data -import Dodge.Data.SoundOrigin -data ItCrWdWd = ItCrWdId - | ItCrWdItemEffect - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ItCrWdWd where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ItCrWdWd -data WdWd = NoWorldEffect - | SetTrigger Bool Int +module Dodge.Data.WorldEffect where + +import Data.Aeson +import Dodge.Data.CreatureEffect +import Dodge.Data.Item +import Dodge.Data.SoundOrigin +import GHC.Generics +import Geometry.Data +import Sound.Data + +data ItCrWdWd + = ItCrWdId + | ItCrWdItemEffect + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON ItCrWdWd where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON ItCrWdWd + +data WdWd + = NoWorldEffect + | SetTrigger Bool Int | WorldEffects [WdWd] | SetLSCol Point3 Int | AccessTerminal (Maybe Int) @@ -29,55 +36,81 @@ data WdWd = NoWorldEffect | WdWdNegateTrig Int | WdWdFromItixCrixWdWd Int Int ItCrWdWd | WdWdFromItCrixWdWd Item Int ItCrWdWd - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON WdWd where + deriving (Eq, Show, Read, Generic) + +instance ToJSON WdWd where toEncoding = genericToEncoding defaultOptions -instance FromJSON WdWd -data WdP2 = WdP2Const Point2 + +instance FromJSON WdWd + +data WdP2 + = WdP2Const Point2 | WdYouPos - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON WdP2 where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON WdP2 where toEncoding = genericToEncoding defaultOptions -instance FromJSON WdP2 -data MdWdWd = MdWdId + +instance FromJSON WdP2 + +data MdWdWd + = MdWdId | MdTrigIf MdWdWd MdWdWd | MdSetLSCol Point3 | MdFlickerUpdate - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON MdWdWd where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON MdWdWd where toEncoding = genericToEncoding defaultOptions -instance FromJSON MdWdWd -data WdBl = WdTrig Int + +instance FromJSON MdWdWd + +data WdBl + = WdTrig Int | WdBlDoorMoving Int | WdBlConst Bool | WdBlNegate WdBl | WdBlCrFilterNearPoint Float Point2 CrBl | WdBlBtOn Int | WdBlBtNotOff Int - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON WdBl where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON WdBl where toEncoding = genericToEncoding defaultOptions -instance FromJSON WdBl -data WdP2f = WdP2f0 + +instance FromJSON WdBl + +data WdP2f + = WdP2f0 | WdP2fDoorPosition Int - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON WdP2f where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON WdP2f where toEncoding = genericToEncoding defaultOptions -instance FromJSON WdP2f -data DrWdWd = DrWdId + +instance FromJSON WdP2f + +data DrWdWd + = DrWdId | DrWdMakeDoorDebris - | DrWdMechanismStepwise Int [Int] [(Point2,Point2)] + | DrWdMechanismStepwise Int [Int] [(Point2, Point2)] | DoorMechanism - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON DrWdWd where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON DrWdWd where toEncoding = genericToEncoding defaultOptions -instance FromJSON DrWdWd -data TmWdWd = TmWdId + +instance FromJSON DrWdWd + +data TmWdWd + = TmWdId | TmWdWdDisconnectTerminal | TmWdWdfromWdWd WdWd | TmWdWdTermSound SoundID | TmWdWdDoDeathTriggers - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TmWdWd where + deriving (Eq, Show, Read, Generic) + +instance ToJSON TmWdWd where toEncoding = genericToEncoding defaultOptions -instance FromJSON TmWdWd + +instance FromJSON TmWdWd diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index d66ff9b9e..94abd446a 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -23,6 +23,7 @@ import Dodge.Data import Dodge.SoundLogic import Geometry import Picture +import Control.Lens defaultEquipment :: Item defaultEquipment = defaultItem @@ -34,9 +35,8 @@ defaultItZoom :: ItZoom defaultItZoom = ItZoom 20 0.2 1 defaultConsumable :: Item defaultConsumable = defaultItem - { _itConsumption = ItemItselfConsumable {_icAmount = 1} - , _itInvColor = blue - } + & itUse .~ ConsumeUse CDoNothing 1 + & itInvColor .~ blue defaultFlIt :: FloorItem defaultFlIt = FlIt {_flItRot=0,_flIt = defaultConsumable, _flItPos = V2 0 0, _flItID = 0} diff --git a/src/Dodge/Default/Item.hs b/src/Dodge/Default/Item.hs index 9d4b0d39c..8f1e232eb 100644 --- a/src/Dodge/Default/Item.hs +++ b/src/Dodge/Default/Item.hs @@ -1,32 +1,32 @@ -module Dodge.Default.Item - ( defaultItem - ) where -import Dodge.Data -import Picture +module Dodge.Default.Item ( + defaultItem, +) where + +import Dodge.Data.Item import Geometry.Data ---import Shape +import Picture defaultItem :: Item -defaultItem = Item - { _itCurseStatus = Uncursed - , _itType = defaultItemType --- , _itEquipPict = \_ _ -> (,) emptySH blank - , _itEffect = NoItEffect - , _itID = Nothing - , _itIsHeld = False - , _itInvColor = yellow - , _itInvSize = 1 - , _itPos = VoidItm - , _itDimension = ItemDimension 2 0 (V3 10 (-5) 3) - , _itConsumption = NoConsumption - , _itUse = NoUse - , _itAttachment = NoItAttachment - , _itParams = NoParams - , _itTweaks = NoTweaks - , _itScope = NoScope - , _itTargeting = NoTargeting - , _itValue = ItemValue 0 MundaneItem - } +defaultItem = + Item + { _itCurseStatus = Uncursed + , _itType = defaultItemType + , -- , _itEquipPict = \_ _ -> (,) emptySH blank + _itEffect = NoItEffect + , _itID = Nothing + , _itIsHeld = False + , _itInvColor = yellow + , _itInvSize = 1 + , _itPos = VoidItm + , _itDimension = ItemDimension 2 0 (V3 10 (-5) 3) + , _itUse = CraftUse (ItAmount 1) + , _itParams = NoParams + , _itTweaks = NoTweaks + , _itScope = NoScope + , _itTargeting = NoTargeting + , _itValue = ItemValue 0 MundaneItem + , _itAttachment = NoItAttachment + } defaultItemType :: ItemType -defaultItemType = ItemType NOTDEFINED mempty NoStack +defaultItemType = ItemType (error "defaultItemType not initialized") mempty NoStack diff --git a/src/Dodge/Default/Weapon.hs b/src/Dodge/Default/Weapon.hs index 478993bb0..13a6c5c9f 100644 --- a/src/Dodge/Default/Weapon.hs +++ b/src/Dodge/Default/Weapon.hs @@ -1,104 +1,123 @@ -module Dodge.Default.Weapon - where -import Dodge.Data -import Dodge.Reloading.Action -import Dodge.Item.Weapon.Bullet -import Dodge.Default.Item +module Dodge.Default.Weapon where + +import Control.Lens +import qualified Data.Map.Strict as M +import Dodge.Data.Ammo +import Dodge.Data.Hammer +import Dodge.Data.Item import Dodge.Default.AimParams ---import Dodge.Item.Draw +import Dodge.Default.Item +import Dodge.Item.Weapon.Bullet +import Dodge.Reloading.Action import Picture -import qualified Data.Map.Strict as M -import Control.Lens - -defaultLeftLoadable :: ItemConsumption +defaultLeftLoadable :: LeftConsumption defaultLeftLoadable = AutoRecharging 10 10 100 100 -defaultLoadable :: ItemConsumption -defaultLoadable = LoadableAmmo - { _laAmmoType = GenericAmmo - , _laMax = 15 - , _laLoaded = 0 - , _laPrimed = True - , _laCycle = [loadEject 10, loadInsert 10, loadPrime 10] - , _laProgress = Nothing - } -defaultBulletLoadable :: ItemConsumption +defaultLoadable :: HeldConsumption +defaultLoadable = + LoadableAmmo + { _laAmmoType = GenericAmmo + , _laMax = 15 + , _laLoaded = 0 + , _laPrimed = True + , _laCycle = [loadEject 10, loadInsert 10, loadPrime 10] + , _laProgress = Nothing + } + +defaultBulletLoadable :: HeldConsumption defaultBulletLoadable = defaultLoadable & laAmmoType .~ basicBullet -defaultChargeable :: ItemConsumption + +defaultChargeable :: LeftConsumption defaultChargeable = ChargeableAmmo 100 100 defaultrUse :: ItemUse -defaultrUse = RightUse - { _rUse = HeldDoNothing - , _useDelay = FixedRate {_rateMax = 8, _rateTime = 0} - , _useMods = HeldModNothing - , _useHammer = HammerUp - , _useAim = defaultAimParams - , _heldScroll = HeldScrollDoNothing - } +defaultrUse = + RightUse + { _rUse = HeldDoNothing + , _useDelay = FixedRate{_rateMax = 8, _rateTime = 0} + , _useMods = HeldModNothing + , _useHammer = HammerUp + , _useAim = defaultAimParams + , _heldScroll = HeldScrollDoNothing + , _heldConsumption = defaultLoadable + } + defaultlUse :: ItemUse -defaultlUse = LeftUse - { _lUse = LDoNothing - , _useDelay = FixedRate {_rateMax = 8, _rateTime = 0} - , _useHammer = HammerUp - , _eqEq = defaultEquip - } +defaultlUse = + LeftUse + { _lUse = LDoNothing + , _useDelay = FixedRate{_rateMax = 8, _rateTime = 0} + , _useHammer = HammerUp + , _eqEq = defaultEquip + , _leftConsumption = defaultLeftLoadable + } + defaultEquip :: Equipment -defaultEquip = Equipment - { _eqSite = GoesOnSpecial - , _eqUse = EDoNothing - , _eqOnEquip = EDoNothing - , _eqOnRemove = EDoNothing - , _eqParams = NoEquipParams - , _eqViewDist = Nothing - } +defaultEquip = + Equipment + { _eqSite = GoesOnSpecial + , _eqUse = EDoNothing + , _eqOnEquip = EDoNothing + , _eqOnRemove = EDoNothing + , _eqParams = NoEquipParams + , _eqViewDist = Nothing + } luseInstantNoH :: Luse -> ItemUse -luseInstantNoH f = defaultlUse - & lUse .~ f - & useDelay .~ NoDelay +luseInstantNoH f = + defaultlUse + & lUse .~ f + & useDelay .~ NoDelay -- TODO change this defaultLeftItem :: Item -defaultLeftItem = defaultWeapon - & itConsumption .~ defaultLeftLoadable +defaultLeftItem = + defaultWeapon + & itUse .~ defaultlUse defaultWeapon :: Item -defaultWeapon = defaultItem - & itConsumption .~ defaultLoadable - & itUse .~ defaultrUse - & itInvColor .~ white - & itType . iyModules .~ M.fromList - [(ModTarget, EMPTYMODULE) - ,(ModTeleport, EMPTYMODULE) - ] +defaultWeapon = + defaultItem + & itUse .~ defaultrUse + & itInvColor .~ white + & itType . iyModules + .~ M.fromList + [ (ModTarget, EMPTYMODULE) + , (ModTeleport, EMPTYMODULE) + ] defaultBulletWeapon :: Item -defaultBulletWeapon = defaultWeapon - & itConsumption .~ defaultBulletLoadable - & itUse . rUse .~ HeldUseAmmoParams -- useAmmoParams - & itType . iyModules . at ModBullet ?~ EMPTYMODULE - & itType . iyModules . at ModBulletSpawn ?~ EMPTYMODULE - & itType . iyModules . at ModBulletTrajectory ?~ EMPTYMODULE +defaultBulletWeapon = + defaultWeapon + & itUse . heldConsumption .~ defaultBulletLoadable + & itUse . rUse .~ HeldUseAmmoParams -- useAmmoParams + & itType . iyModules . at ModBullet ?~ EMPTYMODULE + & itType . iyModules . at ModBulletSpawn ?~ EMPTYMODULE + & itType . iyModules . at ModBulletTrajectory ?~ EMPTYMODULE defaultItemValue :: ItemValue defaultItemValue = ItemValue 10 MundaneItem + defaultCraftable :: Item -defaultCraftable = defaultItem - { _itInvColor = green - } +defaultCraftable = + defaultItem + { _itInvColor = green + } + defBulletShooter :: ItemParams -defBulletShooter = BulletShooter - { _muzVel = 1 - , _rifling = 0.8 - , _bore = 2 - , _gunBarrels = SingleBarrel 0 - , _recoil = 0 - , _torqueAfter = 0 - , _randomOffset = 0 - } - +defBulletShooter = + BulletShooter + { _muzVel = 1 + , _rifling = 0.8 + , _bore = 2 + , _gunBarrels = SingleBarrel 0 + , _recoil = 0 + , _torqueAfter = 0 + , _randomOffset = 0 + } + defaultAutoGun :: Item -defaultAutoGun = defaultBulletWeapon - & itUse . useAim . aimStance .~ TwoHandTwist +defaultAutoGun = + defaultBulletWeapon + & itUse . useAim . aimStance .~ TwoHandTwist diff --git a/src/Dodge/Distortion.hs b/src/Dodge/Distortion.hs index f070eed03..7414babbf 100644 --- a/src/Dodge/Distortion.hs +++ b/src/Dodge/Distortion.hs @@ -1,5 +1,5 @@ module Dodge.Distortion where -import Dodge.Distortion.Data +import Dodge.Data.Distortion updateDistortion :: Distortion -> Maybe Distortion updateDistortion dt = case dt of diff --git a/src/Dodge/Distortion/Data.hs b/src/Dodge/Distortion/Data.hs deleted file mode 100644 index f7ef063d9..000000000 --- a/src/Dodge/Distortion/Data.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ---{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Distortion.Data where -import GHC.Generics -import Data.Aeson -import Geometry - -data Distortion - = RadialDistortion Point2 Point2 Point2 Float - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Distortion where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Distortion diff --git a/src/Dodge/Equipment.hs b/src/Dodge/Equipment.hs index 541849431..d42a12c1e 100644 --- a/src/Dodge/Equipment.hs +++ b/src/Dodge/Equipment.hs @@ -1,10 +1,15 @@ module Dodge.Equipment where -import Dodge.Data +--import Data.Strict.IntMap.Autogen.Merge.Strict +import Data.IntMap.Merge.Strict +import Dodge.Data import qualified IntMapHelp as IM -import Data.Strict.IntMap.Autogen.Merge.Strict ---import Data.IntMap.Merge.Strict getCrEquipment :: Creature -> IM.IntMap Item -getCrEquipment cr = merge dropMissing dropMissing (zipWithMatched $ \_ _ -> id) - (_crInvEquipped cr) (_crInv cr) +getCrEquipment cr = + merge + dropMissing + dropMissing + (zipWithMatched $ \_ _ -> id) + (_crInvEquipped cr) + (_crInv cr) diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index afdd63e0c..92b4e4346 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -11,44 +11,47 @@ Nor could we handle continuous mouse button input. Instead we store button presses (in a Map) and deal with the combinations in the simulation step; in particular see 'updatePressedButtons'. -} -module Dodge.Event - ( handleEvent - ) where -import Dodge.Terminal -import Dodge.Tweak -import Dodge.HeldScroll -import Dodge.InputFocus -import Dodge.Combine -import Dodge.Event.Keyboard -import Dodge.Base -import Dodge.Data -import Dodge.PreloadData -import Dodge.Inventory -import Dodge.SoundLogic -import qualified IntMapHelp as IM +module Dodge.Event ( + handleEvent, +) where import Control.Lens -import Data.Maybe import qualified Data.Map.Strict as M +import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T +import Dodge.Base +import Dodge.Combine +import Dodge.Data +import Dodge.Event.Keyboard +import Dodge.HeldScroll +import Dodge.InputFocus +import Dodge.Inventory +import Dodge.PreloadData +import Dodge.SoundLogic +import Dodge.Terminal +import Dodge.Tweak +import qualified IntMapHelp as IM import SDL handleEvent :: Event -> Universe -> IO (Maybe Universe) handleEvent e = case eventPayload e of - TextInputEvent tev -> return . Just . handleTextInput (textInputEventText tev) - KeyboardEvent kev -> handleKeyboardEvent kev - MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev - MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev) - MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev + TextInputEvent tev -> return . Just . handleTextInput (textInputEventText tev) + KeyboardEvent kev -> handleKeyboardEvent kev + MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev + MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev) + MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev WindowSizeChangedEvent sev -> handleResizeEvent sev - WindowMovedEvent mev -> return . handleWindowMoveEvent mev - _ -> return . Just + WindowMovedEvent mev -> return . handleWindowMoveEvent mev + _ -> return . Just handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe -handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2 - (fromIntegral x - 0.5*_windowX cfig) - (0.5*_windowY cfig - fromIntegral y) +handleMouseMotionEvent mmev u = + Just $ + u & uvWorld . mousePos + .~ V2 + (fromIntegral x - 0.5 * _windowX cfig) + (0.5 * _windowY cfig - fromIntegral y) where cfig = _uvConfig u P (V2 x y) = mouseMotionEventPos mmev @@ -56,26 +59,30 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2 handleMouseButtonEvent :: MouseButtonEventData -> World -> World handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of Released -> mouseButtons . at thebutton .~ Nothing - Pressed -> mouseButtons . at thebutton ?~ False + Pressed -> mouseButtons . at thebutton ?~ False where thebutton = mouseButtonEventButton mbev -{- | Sets window position in config. -} +-- | Sets window position in config. handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe -handleWindowMoveEvent mev = Just - . (uvConfig . windowPosX .~ fromIntegral x) - . (uvConfig . windowPosY .~ fromIntegral y) +handleWindowMoveEvent mev = + Just + . (uvConfig . windowPosX .~ fromIntegral x) + . (uvConfig . windowPosY .~ fromIntegral y) where P (V2 x y) = windowMovedEventPosition mev -{- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -} +-- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. + -- using a sideeffect here for the io change seems to work better, more testing -- later may be a good idea handleResizeEvent :: WindowSizeChangedEventData -> Universe -> IO (Maybe Universe) -handleResizeEvent sev u = return . Just $ u - & uvConfig . windowX .~ fromIntegral x - & uvConfig . windowY .~ fromIntegral y - & uvIOEffects %~ sideEffectUpdatePreload divRes x y +handleResizeEvent sev u = + return . Just $ + u + & uvConfig . windowX .~ fromIntegral x + & uvConfig . windowY .~ fromIntegral y + & uvIOEffects %~ sideEffectUpdatePreload divRes x y where x = fromIntegral x' y = fromIntegral y' @@ -91,44 +98,51 @@ handleMouseWheelEvent mwev w = case _menuLayers w of wheelEvent :: Float -> World -> World wheelEvent y w = case _hudElement $ _hud (_cWorld w) of DisplayCarte - | rbDown -> w & cWorld . hud . carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * ) + | rbDown -> w & cWorld . hud . carteZoom %~ min 0.75 . max 0.05 . ((1 + y * 0.1) *) | otherwise -> w & cWorld . selLocation %~ (`mod` numLocs) . (+ yi) DisplayInventory NoSubInventory - -- functions that modify the inventory should be centralised so that - -- this lock can be sensibly applied, perhaps + -- functions that modify the inventory should be centralised so that + -- this lock can be sensibly applied, perhaps | _crInvLock (_creatures (_cWorld w) IM.! _yourID (_cWorld w)) -> w - | rbDown -> case (yourItem w ^? _Just . itUse . heldScroll,_rbOptions w) of - (_,EquipOptions{}) -> scrollRBOption y w - (Nothing,_) -> closeObjScrollDir y w - (Just f,_) -> w & cWorld . creatures . ix 0 . crInv . ix (crSel $ you w) %~ doHeldScroll f y (you w) + | rbDown -> case (yourItem w ^? _Just . itUse . heldScroll, _rbOptions w) of + (_, EquipOptions{}) -> scrollRBOption y w + (Nothing, _) -> closeObjScrollDir y w + (Just f, _) -> w & cWorld . creatures . ix 0 . crInv . ix (crSel $ you w) %~ doHeldScroll f y (you w) | lbDown -> w & cWorld . cameraZoom +~ y | invKeyDown -> changeSwapInvSel yi w - | otherwise -> stopSoundFrom (CrReloadSound 0) $ changeAugInvSel yi w - DisplayInventory TweakInventory + | otherwise -> stopSoundFrom (CrReloadSound 0) $ changeAugInvSel yi w + DisplayInventory (TweakInventory mi) | invKeyDown && rbDown -> w & moveTweakSel yi | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvSel yi w - | rbDown -> w & changeTweakParam yi - | otherwise -> w & moveTweakSel yi - DisplayInventory (CombineInventory _) -> w - & cWorld . hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi) + | rbDown -> w & changeTweakParam mi yi + | otherwise -> w & moveTweakSel yi + DisplayInventory CombineInventory{} -> + w + & cWorld . hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi) DisplayInventory (DisplayTerminal tmid) - | rbDown && inTermFocus w -> guardDisconnectedID tmid w $ w - & cWorld . terminals . ix tmid %~ updatetermsubsel - | inTermFocus w -> w - & cWorld . terminals . ix tmid %~ updatetermsel + | rbDown && inTermFocus w -> + guardDisconnectedID tmid w $ + w + & cWorld . terminals . ix tmid %~ updatetermsubsel + | inTermFocus w -> + w + & cWorld . terminals . ix tmid %~ updatetermsel _ -> w where updatetermsel tm = case tm ^? tmInput . tiSel of - Nothing -> tm & tmInput . tiSel .~ (0,0) - Just (i,_) -> let newi = (i - yi) `mod` length (scrollCommands tm) - in tm & setInput newi 0 w + Nothing -> tm & tmInput . tiSel .~ (0, 0) + Just (i, _) -> + let newi = (i - yi) `mod` length (scrollCommands tm) + in tm & setInput newi 0 w 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 w - setInput i j w' tm = tm - & tmInput . tiSel .~ (i,j) - & tmInput . tiText .~ T.pack (_tcString tc ++ " " ++ arg) + 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 w + setInput i j w' tm = + tm + & tmInput . tiSel .~ (i, j) + & tmInput . tiText .~ T.pack (_tcString tc ++ " " ++ arg) where tc = scrollCommands tm !! i arg = getArguments' tc tm w' !! j @@ -144,37 +158,39 @@ getArguments' tc tm = ("" :) . getArguments tc tm getArguments :: TerminalCommand -> Terminal -> World -> [String] getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of - NoArguments {} -> [] + NoArguments{} -> [] OneArgument _ m -> M.keys m scrollCommands :: Terminal -> [TerminalCommand] scrollCommands = (nullCommand :) . _tmScrollCommands + nullCommand :: TerminalCommand -nullCommand = TerminalCommand - { _tcString = "" - , _tcAlias = [] - , _tcHelp = "" - , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments [] - } +nullCommand = + TerminalCommand + { _tcString = "" + , _tcAlias = [] + , _tcHelp = "" + , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments [] + } scrollRBOption :: Float -> World -> World scrollRBOption y w - | y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w))-1) . (+1)) + | y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w)) -1) . (+ 1)) | y > 0 = w & rbOptions . opSel %~ (max 0 . subtract 1) | otherwise = w moveTweakSel :: Int -> World -> World moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of - Just l -> w & cWorld . creatures . ix (_yourID (_cWorld w)) . crInv . ix (crSel (you w)) - . itTweaks . tweakSel %~ (`mod` length l) . subtract i + Just l -> w & cWorld . hud . hudElement . subInventory . tweakInvSel . _Just %~ (`mod` length l) . subtract i _ -> w -changeTweakParam :: Int -> World -> World -changeTweakParam i w = w - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInv . ix (crSel (you w)) %~ - ( (itTweaks . tweakParams . ix paramid . tweakVal .~ x) - . doTweak (_tweakType params) x) - where - tweaks = _itTweaks . fromJust $ yourItem w - params = _tweakParams tweaks IM.! paramid - x = (_tweakVal params + i) `mod` _tweakMax params - paramid = _tweakSel tweaks + +changeTweakParam :: Maybe Int -> Int -> World -> World +changeTweakParam mi i w = fromMaybe w $ do + paramid <- mi + params <- yourItem w ^? _Just . itTweaks . tweakParams . ix paramid + let x = (_tweakVal params + i) `mod` _tweakMax params + return $ + w & cWorld . creatures . ix (_yourID (_cWorld w)) . crInv . ix (crSel (you w)) + %~ ( (itTweaks . tweakParams . ix paramid . tweakVal .~ x) + . doTweak (_tweakType params) x + ) diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 055dd3e7f..3aae23a1c 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -93,7 +93,7 @@ handlePressedKeyInGame scode uv = case scode of ScancodeM -> over uvWorld toggleMap uv ScancodeR -> over uvWorld (crToggleReloading (you w)) uv ScancodeT -> over uvWorld testEvent uv - ScancodeX -> uv & uvWorld . cWorld . hud . hudElement %~ toggleTweakInv + ScancodeX -> uv & uvWorld %~ toggleTweakInv ScancodeC -> over uvWorld toggleCombineInv uv ScancodeI -> uv & uvWorld . cWorld . hud . hudElement %~ toggleInspectInv _ -> uv @@ -114,10 +114,13 @@ handlePressedKeyTerminal tmid scode w = case scode of Nothing -> t Just (t',_) -> t' -toggleTweakInv :: HUDElement -> HUDElement -toggleTweakInv he = case he of - DisplayInventory TweakInventory -> DisplayInventory NoSubInventory - _ -> DisplayInventory TweakInventory +toggleTweakInv :: World -> World +toggleTweakInv w = case w ^. cWorld . hud . hudElement of + DisplayInventory TweakInventory{} -> w & thepointer .~ DisplayInventory NoSubInventory + _ -> w & thepointer .~ DisplayInventory (TweakInventory mi) + where + thepointer = cWorld . hud . hudElement + mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0)) toggleInspectInv :: HUDElement -> HUDElement toggleInspectInv he = case he of diff --git a/src/Dodge/FloorItem.hs b/src/Dodge/FloorItem.hs index 9d08dfaf2..9a1dbbdb9 100644 --- a/src/Dodge/FloorItem.hs +++ b/src/Dodge/FloorItem.hs @@ -28,7 +28,7 @@ copyItemToFloorID pos it w = (,) flid $ w' _ -> id flid = IM.newKey $ _floorItems (_cWorld w) theflit = FlIt - {_flIt = it & itConsumption . icAmount %~ const 1 + {_flIt = it & itUse . useAmount %~ const 1 ,_flItPos = p' ,_flItRot = rot ,_flItID = flid diff --git a/src/Dodge/HeldScroll.hs b/src/Dodge/HeldScroll.hs index a39568dc0..b64075def 100644 --- a/src/Dodge/HeldScroll.hs +++ b/src/Dodge/HeldScroll.hs @@ -10,28 +10,16 @@ doHeldScroll :: HeldScroll -> Float -> Creature -> Item -> Item doHeldScroll hs = case hs of HeldScrollDoNothing -> const . const id HeldScrollZoom -> zoomLongGun - HeldScrollCharMode -> scrollCharMode -scrollCharMode - :: Float -- ^ Amount scrolled - -> Creature - -> Item - -> Item -scrollCharMode x _ - | x > 0 = incCharMode - | x < 0 = decCharMode - | otherwise = id + HeldScrollCharMode {} -> \ x _ -> itUse . heldScroll . hsCharMode %~ cycleSignum x + HeldScrollInt {} -> undefined -incCharMode - :: Item - -> Item -incCharMode = itAttachment . atCharMode %~ cycleL - where - cycleL (x :<| xs) = xs |> x - cycleL xs = xs -decCharMode - :: Item - -> Item -decCharMode = itAttachment . atCharMode %~ cycleR - where - cycleR (xs :|> x) = x <| xs - cycleR xs = xs +cycleSignum :: Float -> Seq a -> Seq a +cycleSignum x + | x > 0 = cycleL + | otherwise = cycleR + +cycleL,cycleR :: Seq a -> Seq a +cycleL (x :<| xs) = xs |> x +cycleL xs = xs +cycleR (xs :|> x) = x <| xs +cycleR xs = xs diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 6fb61142e..80792240a 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -349,7 +349,7 @@ useMod hm = case hm of where p = fromMaybe (_crPos cr) $ it ^? itTargeting . tgPos . _Just a = argV (mouseWorldPos w -.- p) - moddelay x = itConsumption . laAmmoType . amBullet . buState .~ DelayedBullet x + moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x modcrpos x cr = cr & crDir %~ tweenAngles x (_crOldDir cr) & crPos %~ tweenPoints x (_crOldPos cr) @@ -373,14 +373,14 @@ useHeld hu = case hu of HeldExplodeRemoteShell itid pjid -> const $ const $ explodeRemoteRocket itid pjid usePjCreation :: Item -> Creature -> World -> World -usePjCreation it = createProjectile (_amPjCreation (_laAmmoType (_itConsumption it))) it +usePjCreation it = createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it usePjCreationX :: Int -> Item -> Creature -> World -> World usePjCreationX i it cr = foldr f - (createProjectile (_amPjCreation (_laAmmoType (_itConsumption it))) it cr) + (createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it cr) [1..i-1] where - f n = (. createProjectile (_amPjCreation (_laAmmoType (_itConsumption it))) it (cr & crDir +~ (2*pi*fromIntegral n / fromIntegral i))) + f n = (. createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it (cr & crDir +~ (2*pi*fromIntegral n / fromIntegral i))) overNozzles :: (Nozzle -> Item -> Creature -> World -> World) -> Item -> Creature -> World -> World @@ -407,7 +407,7 @@ overNozzle eff it cr w nz = wa = min maxa $ max (negate maxa) (_nzCurrentWalkAngle nz + walkamount) useGasParams :: Nozzle -> Item -> Creature -> World -> World -useGasParams nz it cr = createGas (_amCreateGas (_laAmmoType (_itConsumption it))) +useGasParams nz it cr = createGas (_amCreateGas (_laAmmoType (_heldConsumption (_itUse it)))) (_nzPressure nz) pos dir cr where dir = _crDir cr @@ -430,18 +430,18 @@ fireRemoteShell it cr w = set (cWorld . creatures . ix cid . crInv . ix j . itUs caneStickSoundChoice :: Item -> SoundID caneStickSoundChoice it - | _laLoaded (_itConsumption it) < 2 = tap3S + | _laLoaded (_heldConsumption (_itUse it)) < 2 = tap3S | otherwise = shotgunS bangStickSoundChoice :: Item -> SoundID bangStickSoundChoice it - | _laLoaded (_itConsumption it) < 2 = tap3S + | _laLoaded (_heldConsumption (_itUse it)) < 2 = tap3S | otherwise = shotgunS coneRandItemUpdate :: State StdGen (Item -> Item) coneRandItemUpdate = do wth <- state $ randomR (1,5) - return (itConsumption . laAmmoType . amBullet . buWidth .~ wth) + return (itUse . heldConsumption . laAmmoType . amBullet . buWidth .~ wth) coneRandItemParams :: State StdGen (ItemParams -> ItemParams) coneRandItemParams = do muzv <- state $ randomR (0.5,1) diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index a1ea65fc1..8f182b2aa 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -53,8 +53,8 @@ rmInvItem :: Int -- ^ Creature id -> Int -- ^ Inventory position -> World -> World -rmInvItem cid invid w = case w ^? cWorld . creatures . ix cid . crInv . ix invid . itConsumption . icAmount of - Just x | x > 1 -> w & cWorld . creatures . ix cid . crInv . ix invid . itConsumption . icAmount %~ subtract 1 +rmInvItem cid invid w = case w ^? cWorld . creatures . ix cid . crInv . ix invid . itUse . useAmount of + Just x | x > 1 -> w & cWorld . creatures . ix cid . crInv . ix invid . itUse . useAmount %~ subtract 1 _ -> w & cWorld . creatures . ix cid . crInv %~ f & cWorld . creatures . ix cid . crInvSel %~ stopCrInvSelAction diff --git a/src/Dodge/Inventory/Add.hs b/src/Dodge/Inventory/Add.hs index e81c29d79..3cad2ccd9 100644 --- a/src/Dodge/Inventory/Add.hs +++ b/src/Dodge/Inventory/Add.hs @@ -15,7 +15,7 @@ putItemInInvID cid flid w = fromMaybe (Nothing,w) $ do return (Just i,w') putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item -putItemInInvSlot = IM.insertWith (const $ itConsumption . icAmount +~ 1) +putItemInInvSlot = IM.insertWith (const $ itUse . useAmount +~ 1) {- | Pick up a specific item. -} tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int,World) diff --git a/src/Dodge/Inventory/CheckSlots.hs b/src/Dodge/Inventory/CheckSlots.hs index d44d76aee..975b33d3e 100644 --- a/src/Dodge/Inventory/CheckSlots.hs +++ b/src/Dodge/Inventory/CheckSlots.hs @@ -1,32 +1,33 @@ module Dodge.Inventory.CheckSlots where -import Dodge.Data + +import Control.Lens +import Data.Maybe import Dodge.Base.You +import Dodge.Data import Dodge.Inventory.ItemSpace import qualified IntMapHelp as IM -import Data.Maybe ---import Control.Lens - --- | checks whether or not an item will fit in your inventory --- if so return Just the next slot to be used +{- | checks whether or not an item will fit in your inventory + if so return Just the next slot to be used +-} checkInvSlotsYou :: Item -> World -> Maybe Int checkInvSlotsYou it w - | crNumFreeSlots ycr >= ceiling (_itInvSize it) - = Just $ findItemSlot it inv + | crNumFreeSlots ycr >= ceiling (_itInvSize it) = + Just $ findItemSlot it inv | otherwise = Nothing - where + where ycr = you w inv = _crInv ycr -- Assumes that the item is singular. -- Do not want to stack floor items for now findItemSlot :: Item -> IM.IntMap Item -> Int -findItemSlot it inv = case _itConsumption it of - ItemItselfConsumable _ - -> fromMaybe newslot $ IM.findIndex (\it' -> _itType it == _itType it') inv - _ -> newslot +findItemSlot it inv = case it ^? itUse . useAmount of + Just _ -> + fromMaybe newslot $ IM.findIndex (\it' -> _itType it == _itType it') inv + _ -> newslot where - newslot = maybe 0 ((+1) . fst) $ IM.lookupMax inv + newslot = maybe 0 ((+ 1) . fst) $ IM.lookupMax inv crNumFreeSlots :: Creature -> Int crNumFreeSlots cr = _crInvCapacity cr - invSize (_crInv cr) diff --git a/src/Dodge/Inventory/ItemSpace.hs b/src/Dodge/Inventory/ItemSpace.hs index 989a279e6..c779f3a0c 100644 --- a/src/Dodge/Inventory/ItemSpace.hs +++ b/src/Dodge/Inventory/ItemSpace.hs @@ -8,6 +8,6 @@ import Control.Lens --import Data.Maybe itSlotsTaken :: Item -> Int -itSlotsTaken it = case it ^? itConsumption . icAmount of +itSlotsTaken it = case it ^? itUse . useAmount of Nothing -> moduleSizes it + ceiling (_itInvSize it) Just i -> moduleSizes it + ceiling (_itInvSize it * fromIntegral i) diff --git a/src/Dodge/ItEffect.hs b/src/Dodge/ItEffect.hs index 49922e851..edcd77c1e 100644 --- a/src/Dodge/ItEffect.hs +++ b/src/Dodge/ItEffect.hs @@ -35,8 +35,8 @@ rewindEffect itm cr w & ptrWpCharge .~ 0 where invid = _ipInvID $ _itPos itm - ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itConsumption . wpCharge - maxcharge = _wpMaxCharge . _itConsumption $ itm + ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge + maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge cw = _cWorld w & rewindWorlds .~ [] diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs index f6aabb115..1e7a28dff 100644 --- a/src/Dodge/Item.hs +++ b/src/Dodge/Item.hs @@ -5,31 +5,24 @@ module Dodge.Item , module Dodge.Item.PassKey , module Dodge.Item.Craftable , itemFromBase - , baseToFamily ) where import Dodge.Data import Dodge.Item.Weapon import Dodge.Item.Equipment import Dodge.Item.Consumable import Dodge.Item.PassKey -import Dodge.Item.Family import Dodge.Item.Craftable -- this is not ideal, should fold the itemtype into a stackable/unstackable type itemFromBase :: ItemBaseType -> Item itemFromBase ibt = case ibt of - NOTDEFINED -> error "cannot create undefined item" - EFFGUN _ -> undefined - AUTOEFFGUN _ -> undefined - -- Weapons HELD ht -> itemFromHeldType ht LEFT lt -> itemFromLeftType lt EQUIP et -> itemFromEquipType et - --GRENADE - --REMOTEBOMB - -- Utility items + Consumable et -> itemFromConsumableType et CRAFT cr -> makeTypeCraft cr - KEYCARD i -> keyCard i +itemFromConsumableType :: ConsumableItemType -> Item +itemFromConsumableType ct = case ct of MEDKIT i -> medkit i itemFromEquipType :: EquipItemType -> Item itemFromEquipType et = case et of @@ -59,6 +52,7 @@ itemFromLeftType lt = case lt of -- Equipment itemFromHeldType :: HeldItemType -> Item itemFromHeldType ht = case ht of + KEYCARD i -> keyCard i TORCH -> torch SHATTERGUN -> shatterGun BANGSTICK i -> bangStick i @@ -118,17 +112,3 @@ itemFromHeldType ht = case ht of HELDDETECTOR d -> clickDetector d FLATSHIELD -> flatShield -baseToFamily :: ItemBaseType -> ItemFamily -baseToFamily ibt = case ibt of - NOTDEFINED -> undefined - EFFGUN _ -> undefined - AUTOEFFGUN _ -> undefined - HELD _ -> HeldFamily - LEFT _ -> LeftClickFamily - EQUIP _ -> EquipmentFamily - CRAFT _ -> CraftingFamily - - KEYCARD _ -> HeldFamily - - MEDKIT _ -> ConsumableFamily - diff --git a/src/Dodge/Item/Amount.hs b/src/Dodge/Item/Amount.hs index e776d5994..03fc32693 100644 --- a/src/Dodge/Item/Amount.hs +++ b/src/Dodge/Item/Amount.hs @@ -3,5 +3,5 @@ import Dodge.Data import Data.Maybe import Control.Lens -itStackAmount :: Item -> IcAmount -itStackAmount it = fromMaybe 1 $ it ^? itConsumption . icAmount +itStackAmount :: Item -> ItAmount +itStackAmount it = fromMaybe 1 $ it ^? itUse . useAmount diff --git a/src/Dodge/Item/Attachment.hs b/src/Dodge/Item/Attachment.hs index f36c96062..dfc164234 100644 --- a/src/Dodge/Item/Attachment.hs +++ b/src/Dodge/Item/Attachment.hs @@ -16,7 +16,7 @@ charFiringStratI :: [(Char, ChainEffect)] -- ^ Different firing effects for different characters -> ChainEffect charFiringStratI strats eff item cr w = case w ^? cWorld . creatures . ix cid . crInv - . ix (crSel $ _creatures (_cWorld w) IM.! cid) . itAttachment . atCharMode of + . ix (crSel $ _creatures (_cWorld w) IM.! cid) . itUse . heldScroll . hsCharMode of Just (c :<| _) -> fromMaybe id (Prelude.lookup c strats) eff item cr w _ -> w where diff --git a/src/Dodge/Item/Consumable.hs b/src/Dodge/Item/Consumable.hs index bc47560e8..d2c46da0a 100644 --- a/src/Dodge/Item/Consumable.hs +++ b/src/Dodge/Item/Consumable.hs @@ -14,12 +14,8 @@ import qualified IntMapHelp as IM medkit :: Int -> Item medkit i = defaultConsumable - { _itUse = ConsumeUse - {_cUse = CHeal i - } - , _itID = Nothing - } - & itType . iyBase .~ MEDKIT i + & itUse . cUse .~ CHeal i + & itType . iyBase .~ Consumable (MEDKIT i) heal25 :: Int -> World -> Maybe World heal25 = heal 25 diff --git a/src/Dodge/Item/Craftable.hs b/src/Dodge/Item/Craftable.hs index 09e1c6b96..197a13d1d 100644 --- a/src/Dodge/Item/Craftable.hs +++ b/src/Dodge/Item/Craftable.hs @@ -13,7 +13,7 @@ makeTypeCraftNum :: Int -> CraftType -> Item makeTypeCraftNum i ct = defaultCraftable & itInvSize .~ 0.5 & itCurseStatus .~ Uncursed - & itConsumption .~ ItemItselfConsumable (IcAmount i) + & itUse . useAmount .~ fromIntegral i & itType . iyBase .~ CRAFT ct makeTypeCraft :: CraftType -> Item diff --git a/src/Dodge/Item/Display.hs b/src/Dodge/Item/Display.hs index 1b64e255d..de91bad02 100644 --- a/src/Dodge/Item/Display.hs +++ b/src/Dodge/Item/Display.hs @@ -1,105 +1,109 @@ -module Dodge.Item.Display - ( itemDisplay - , selectedItemDisplay - , itemString - ) - where -import Dodge.Module -import Dodge.Data -import Dodge.Inventory.ItemSpace -import Padding -import LensHelp +module Dodge.Item.Display ( + itemDisplay, + selectedItemDisplay, + itemString, +) where import Data.Maybe import Data.Sequence +import Dodge.Data +import Dodge.Inventory.ItemSpace +import Dodge.Module +import LensHelp +import Padding + +itemDisplay :: Item -> [String] +itemDisplay it = itemDisplayWithNumber (showConsumption (_itUse it)) it + +itemDisplayWithNumber :: String -> Item -> [String] +itemDisplayWithNumber numberstr it = + Prelude.take (itSlotsTaken it) $ + (midPadL 15 ' ' thename (' ' : numberstr) ++ theparam) : + catMaybes [maybeWarmupStatus it, maybeRateStatus it] + ++ moduleStrings it + ++ repeat "*" + where + thename = itemBaseName it + theparam = + fromMaybe [] + . listToMaybe + $ mapMaybe + ($ it) + [ maybeModeStatus + ] itemString :: Item -> String itemString = head . itemDisplay itemBaseName :: Item -> String -itemBaseName it = case _iyBase $ _itType it of +itemBaseName it = case _iyBase $ _itType it of CRAFT str -> show str - HELD hit -> case hit ^? xNum of - Just i -> takeWhile (/=' ') (show hit) ++ show i + HELD hit -> case hit ^? xNum of + Just i -> takeWhile (/= ' ') (show hit) ++ show i Nothing -> show hit - x -> show x - -itemDisplayWithNumber :: String -> Item -> [String] -itemDisplayWithNumber numberstr it = Prelude.take (itSlotsTaken it) $ - (midPadL 15 ' ' thename (' ' : numberstr) ++ theparam) - : catMaybes [maybeWarmupStatus it,maybeRateStatus it] - ++ moduleStrings it ++ repeat "*" - where - thename = itemBaseName it - theparam = fromMaybe [] - . listToMaybe - $ mapMaybe ($ it) - [ maybeModeStatus - ] + LEFT lit -> show lit + EQUIP eit -> show eit + Consumable cit -> show cit selectedItemDisplay :: Creature -> Item -> [String] -selectedItemDisplay cr it = itemDisplayWithNumber (showSelectedConsumption cr (_itConsumption it)) it +selectedItemDisplay cr it = itemDisplayWithNumber (showSelectedConsumption cr (_itUse it)) it -{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -} --- TODO make work on remote launchers -itemDisplay :: Item -> [String] -itemDisplay it = itemDisplayWithNumber (showConsumption (_itConsumption it)) it +-- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. +showSelectedConsumption :: Creature -> ItemUse -> String +showSelectedConsumption cr iu = case iu of + RightUse{} -> showReloadProgress cr (_heldConsumption iu) + LeftUse{} -> showAutoRechargeProgress (_leftConsumption iu) + EquipUse{} -> "" + _ -> show $ iu ^?! useAmount . getItAmount -- partial, be careful if adding new data constructors -showSelectedConsumption :: Creature -> ItemConsumption -> String -showSelectedConsumption cr ic = case ic of - LoadableAmmo{} -> showReloadProgress cr ic - AutoRecharging {} -> showAutoRechargeProgress ic - ChargeableAmmo{} -> show $ _wpCharge ic - ItemItselfConsumable{} -> show (_icAmount ic) - NoConsumption -> "" +showAutoRechargeProgress :: LeftConsumption -> String +showAutoRechargeProgress lc = case lc of + AutoRecharging{} + | _arLoaded lc < _arMax lc -> show (_arProgress lc) ++ "C" ++ show (_arLoaded lc) + | otherwise -> show (_arLoaded lc) + ChargeableAmmo{} -> show (_wpCharge lc) -showAutoRechargeProgress :: ItemConsumption -> String -showAutoRechargeProgress ic - | l < _arMax ic = show (_arProgress ic) ++ "C" ++ show l - | otherwise = show l - where - l = _arLoaded ic - -showReloadProgress :: Creature -> ItemConsumption -> String +showReloadProgress :: Creature -> HeldConsumption -> String showReloadProgress cr ic = case cr ^?! crInvSel . iselAction of ReloadAction i la _ -> show i ++ showLoadActionType la (_laLoaded ic) _ -> case ic ^? laProgress . _Just . ix 0 of Nothing -> show $ _laLoaded ic Just la -> show (_actionTime la) ++ showLoadActionType la (_laLoaded ic) -showLoadProgress :: Int -> Maybe [LoadAction] -> String -showLoadProgress x mlas = case mlas ^? _Just . ix 0 of - Just la -> show (_actionTime la) ++ showLoadActionType la x - Nothing -> show x +showConsumption :: ItemUse -> String +showConsumption iu = case iu of + RightUse{} -> showReloadProgress' (_heldConsumption iu) + LeftUse{} -> showAutoRechargeProgress (_leftConsumption iu) + EquipUse{} -> "" + _ -> show $ iu ^?! useAmount . getItAmount -showConsumption :: ItemConsumption -> String -showConsumption ic = case ic of - LoadableAmmo{} -> showLoadProgress (_laLoaded ic) (_laProgress ic) - AutoRecharging {} -> showAutoRechargeProgress ic - ChargeableAmmo{} -> show $ _wpCharge ic - ItemItselfConsumable{} -> show (_icAmount ic) - NoConsumption -> "" +showReloadProgress' :: HeldConsumption -> String +showReloadProgress' ic = case ic ^? laProgress . _Just . ix 0 of + Nothing -> show $ _laLoaded ic + Just la -> show (_actionTime la) ++ showLoadActionType la (_laLoaded ic) showLoadActionType :: LoadAction -> Int -> String showLoadActionType la x = case la of - LoadEject {} -> "E" - LoadInsert {} -> "L" - LoadAdd {} -> "A" ++ show x - LoadPrime {} -> "P" + LoadEject{} -> "E" + LoadInsert{} -> "L" + LoadAdd{} -> "A" ++ show x + LoadPrime{} -> "P" maybeWarmupStatus :: Item -> Maybe String maybeWarmupStatus it = case it ^? itUse . useDelay . warmMax of Nothing -> Nothing - Just m -> case m - (_warmTime . _useDelay $ _itUse it) of - x | x <= 1 -> Just "*WARM" - | otherwise -> let n = show x - in Just $ Prelude.take (5 - Prelude.length n) "*WARM" ++ n + Just m -> case m - (_warmTime . _useDelay $ _itUse it) of + x + | x <= 1 -> Just "*WARM" + | otherwise -> + let n = show x + in Just $ Prelude.take (5 - Prelude.length n) "*WARM" ++ n maybeModeStatus :: Item -> Maybe String -maybeModeStatus it = case it ^? itAttachment of - Just AttachCharMode {_atCharMode = (c :<| _)} -> Just [' ',c] - Just AttachMode {_atMode = i} -> Just $ show i - _ -> Nothing +maybeModeStatus it = case it ^? itUse . heldScroll of + Just HeldScrollCharMode{_hsCharMode = (c :<| _)} -> Just [' ', c] + Just HeldScrollInt{_hsInt = i} -> Just $ show i + _ -> Nothing maybeRateStatus :: Item -> Maybe String maybeRateStatus it = case it ^? itUse . useDelay . rateMaxMax of diff --git a/src/Dodge/Item/Draw/SPic.hs b/src/Dodge/Item/Draw/SPic.hs index 17e506ade..63af8d30b 100644 --- a/src/Dodge/Item/Draw/SPic.hs +++ b/src/Dodge/Item/Draw/SPic.hs @@ -16,15 +16,7 @@ itemSPic it = foldMap (modulesSPic it) (_iyModules $ _itType it) <> case it ^. i HELD ht -> heldItemSPic ht it LEFT lt -> leftItemSPic lt it EQUIP et -> equipItemSPic et it - NOTDEFINED -> defSPic - EFFGUN _ -> defSPic - AUTOEFFGUN _ -> defSPic - --- --- - KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic) --- - MEDKIT _ -> defSPic + Consumable {} -> defSPic equipItemSPic :: EquipItemType -> Item -> SPic equipItemSPic et _ = case et of @@ -100,6 +92,7 @@ heldItemSPic ht it = case ht of DRONELAUNCHER -> defSPic SHATTERGUN -> shatterGunSPic HELDDETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPoly 3 $ rectWH 2 2) + KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic) torchShape :: Shape torchShape = colorSH blue @@ -132,7 +125,7 @@ baseStickShape :: Shape baseStickShape = colorSH green $ upperPrismPoly 3 $ rectXH 10 2 stickClip :: Item -> Shape -stickClip it = case it ^? itConsumption . laLoaded of +stickClip it = case it ^? itUse . heldConsumption . laLoaded of Just x | x > 0 -> foldMap f [0..x-1] _ -> mempty where @@ -163,7 +156,7 @@ baseRifleShape :: Shape baseRifleShape = colorSH red $ upperPrismPoly 3 $ rectXH 25 2 makeSingleClipAt :: Point3 -> Item -> Shape -makeSingleClipAt p it = case it ^? itConsumption . laLoaded of +makeSingleClipAt p it = case it ^? itUse . heldConsumption . laLoaded of Just 0 -> mempty _ -> translateSH p $ upperPrismPoly 1 $ square 1.5 @@ -172,7 +165,7 @@ makeTinClipAt r p it = translateSH p . overPosSH (rotate3z r) $ upperPrismPoly 1 $ rectNSWE 0 (-y) (-2) 2 where y = fromIntegral y' * 0.3 - y' = fromMaybe 0 $ it ^? itConsumption . laLoaded + y' = fromMaybe 0 $ it ^? itUse . heldConsumption . laLoaded volleyGunSPic :: Int -> Item -> SPic volleyGunSPic i it = noPic $ @@ -183,7 +176,7 @@ volleyGunSPic i it = noPic $ caneClipX :: Int -> Item -> Shape -caneClipX i it = case it ^? itConsumption . laLoaded of +caneClipX i it = case it ^? itUse . heldConsumption . laLoaded of Just la | la > 0 -> foldMap ( (\y -> translateSH (V3 5 0 3) . upperPrismPoly 1 $ map (+.+ V2 0 y) $ square 1.5) . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))) @@ -191,9 +184,9 @@ caneClipX i it = case it ^? itConsumption . laLoaded of _ -> mempty miniGunXPictItem :: Int -> Item -> SPic -miniGunXPictItem i it = miniGunXPict i spin (_laLoaded $ _itConsumption it) +miniGunXPictItem i it = miniGunXPict i spin (_laLoaded $ _heldConsumption (_itUse it)) where - spin = (-10) * _laLoaded (_itConsumption it) + _warmTime (_useDelay $ _itUse it) + spin = (-10) * _laLoaded (_heldConsumption (_itUse it)) + _warmTime (_useDelay $ _itUse it) miniGunXPict :: Int -> Int -> Int -> SPic miniGunXPict i spin _ = @@ -216,7 +209,7 @@ baseSonicShape :: Shape baseSonicShape = colorSH rose $ upperPrismPoly 3 $ rectXH 25 2 revolverClip :: Item -> Shape -revolverClip it = case it ^? itConsumption . laLoaded of +revolverClip it = case it ^? itUse . heldConsumption . laLoaded of Just al | al > 0 -> translateSH (V3 5 0 1) $ foldMap f [1..al] _ -> mempty where diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index 166d301a1..1e77ede92 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -1,109 +1,120 @@ -module Dodge.Item.Equipment - ( module Dodge.Item.Equipment.Booster - , torch - , magShield - , powerLegs - , flatShield - , wristInvisibility - , wristArmour - , hat - , brainHat - , frontArmour - , headLamp - , headLamp1 - , jetPack - , speedLegs - , jumpLegs - , flameShield +module Dodge.Item.Equipment ( + module Dodge.Item.Equipment.Booster, + torch, + magShield, + powerLegs, + flatShield, + wristInvisibility, + wristArmour, + hat, + brainHat, + frontArmour, + headLamp, + headLamp1, + jetPack, + speedLegs, + jumpLegs, + flameShield, + useMagShield, + setWristShieldPos, + createHeadLamp, + overCID, + onEquipWristShield, + onRemoveWristShield, + createShieldWall, + removeShieldWall, +) where - , useMagShield - , setWristShieldPos - , createHeadLamp - , overCID - , onEquipWristShield - , onRemoveWristShield - - , createShieldWall - , removeShieldWall - ) where -import Dodge.Data -import Dodge.Item.Draw -import Dodge.Item.Equipment.Booster -import Dodge.LightSource -import Dodge.Default -import Dodge.Creature.Test +import Data.Maybe import Dodge.Creature.HandPos +import Dodge.Creature.Test +import Dodge.Data +import Dodge.Default +import Dodge.Item.Equipment.Booster +import Dodge.Item.HeldOffset +import Dodge.LightSource import Dodge.Wall import Dodge.Wall.ForceField -import Picture import Geometry import qualified IntMapHelp as IM import LensHelp - -import Data.Maybe +import Picture magShield :: Item -magShield = defaultEquipment - { _itID = Nothing - , _itAttachment = AttachMInt Nothing - } - & itUse . eqEq . eqUse .~ EMagShield --useMagShield - & itUse . eqEq . eqSite .~ GoesOnWrist - & itType . iyBase .~ EQUIP MAGSHIELD +magShield = + defaultEquipment + { _itID = Nothing + , _itAttachment = AttachMInt Nothing + } + & itUse . eqEq . eqUse .~ EMagShield --useMagShield + & itUse . eqEq . eqSite .~ GoesOnWrist + & itType . iyBase .~ EQUIP MAGSHIELD + useMagShield :: Item -> Creature -> World -> World useMagShield it cr w = w & cWorld . magnets . at mgid ?~ themagnet where - themagnet = Magnet - {_mgID = mgid - ,_mgUpdate = MagnetUpdateTimer 1 - ,_mgPos = _crPos cr - ,_mgField = MagnetBuBuCurveAroundField 50 200 - } + themagnet = + Magnet + { _mgID = mgid + , _mgUpdate = MagnetUpdateTimer 1 + , _mgPos = _crPos cr + , _mgField = MagnetBuBuCurveAroundField 50 200 + } mgid = case it ^? itAttachment . atMInt . _Just of Just mgid' -> mgid' Nothing -> IM.newKey $ _magnets (_cWorld w) + -- it = _crInv cr IM.! invid -flameShield :: Item -flameShield = defaultEquipment - { _itID = Nothing - } & itUse . eqEq . eqSite .~ GoesOnChest - & itType . iyBase .~ EQUIP FLAMESHIELD -{- | Slows you down, blocks forward projectiles. -} +flameShield :: Item +flameShield = + defaultEquipment + { _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnChest + & itType . iyBase .~ EQUIP FLAMESHIELD + +-- | Slows you down, blocks forward projectiles. frontArmour :: Item -frontArmour = defaultEquipment - { _itID = Nothing - } - & itUse . eqEq . eqSite .~ GoesOnChest - & itType . iyBase .~ EQUIP FRONTARMOUR +frontArmour = + defaultEquipment + { _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnChest + & itType . iyBase .~ EQUIP FRONTARMOUR wristArmour :: Item -wristArmour = defaultEquipment - {_itID = Nothing - } - & itUse . eqEq . eqSite .~ GoesOnWrist - & itUse . eqEq . eqOnEquip .~ EonWristShield --onEquipWristShield - & itUse . eqEq . eqUse .~ EWristShield --setWristShieldPos - & itUse . eqEq . eqOnRemove .~ EoffWristShield --onRemoveWristShield - & itType . iyBase .~ EQUIP WRISTARMOUR +wristArmour = + defaultEquipment + { _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnWrist + & itUse . eqEq . eqOnEquip .~ EonWristShield --onEquipWristShield + & itUse . eqEq . eqUse .~ EWristShield --setWristShieldPos + & itUse . eqEq . eqOnRemove .~ EoffWristShield --onRemoveWristShield + & itType . iyBase .~ EQUIP WRISTARMOUR onEquipWristShield :: Item -> Creature -> World -> World -onEquipWristShield itm cr w = w - & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID (_itPos itm)) . itUse . eqEq . eqParams .~ EquipID i - & cWorld . walls . at i ?~ forceField {_wlID = i} - & setWristShieldPos (itm & itUse . eqEq . eqParams .~ EquipID i) cr +onEquipWristShield itm cr w = + w + & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID (_itPos itm)) . itUse . eqEq . eqParams .~ EquipID i + & cWorld . walls . at i ?~ forceField{_wlID = i} + & setWristShieldPos (itm & itUse . eqEq . eqParams .~ EquipID i) cr where i = IM.newKey (_walls (_cWorld w)) onRemoveWristShield :: Item -> Creature -> World -> World -onRemoveWristShield itm cr w = w - & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID (_itPos itm)) . itUse . eqEq . eqParams .~ NoEquipParams - & deleteWallID i +onRemoveWristShield itm cr w = + w + & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID (_itPos itm)) . itUse . eqEq . eqParams .~ NoEquipParams + & deleteWallID i where i = _eparamID $ _eqParams $ _eqEq $ _itUse itm + setWristShieldPos :: Item -> Creature -> World -> World -setWristShieldPos itm cr w = w - & moveWallIDUnsafe i wlline +setWristShieldPos itm cr w = + w + & moveWallIDUnsafe i wlline where i = _eparamID $ _eqParams $ _eqEq $ _itUse itm wlline = (f (V3 (-10) 7 0), f (V3 10 7 0)) @@ -112,160 +123,185 @@ setWristShieldPos itm cr w = w handtrans = case cr ^? crInvEquipped . ix invid of Just OnLeftWrist -> \cr' -> translatePointToLeftHand cr' . g _ -> translatePointToRightHand - g | twists cr = (+.+.+ V3 (-5) 10 0) - | otherwise = id + g + | twists cr = (+.+.+ V3 (-5) 10 0) + | otherwise = id f = (+.+ _crPos cr) . stripZ . rotate3 (_crDir cr) . handtrans cr torch :: Item -torch = defaultWeapon - & itEffect .~ effectOnOffHeld CreateHeldLight NoInvEffect-- createHeldLight (const $ const id) - & itType . iyBase .~ HELD TORCH - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 10 +torch = + defaultWeapon + & itEffect .~ effectOnOffHeld CreateHeldLight NoInvEffect -- createHeldLight (const $ const id) + & itType . iyBase .~ HELD TORCH + & itUse . useAim . aimHandlePos .~ 5 + & itUse . useAim . aimMuzPos .~ 10 flatShield :: Item -flatShield = defaultWeapon - & itEffect .~ effectOnOffHeld CreateShieldWall RemoveShieldWall --createShieldWall removeShieldWall - -- the above seems to work, but I am not sure why: it may break on edge - -- cases - & itUse .~ defaultrUse - { _rUse = HeldDoNothing - , _useDelay = NoDelay - , _useMods = HeldModNothing - , _useHammer = HammerUp - , _useAim = AimParams - { _aimWeight = 5 - , _aimRange = 0 - , _aimZoom = ItZoom 20 0.2 1 - , _aimStance = TwoHandFlat - , _aimHandlePos = 0 - , _aimMuzPos = 0 - } - } - & itInvSize .~ 3 - & itType . iyBase .~ HELD FLATSHIELD +flatShield = + defaultWeapon + & itEffect .~ effectOnOffHeld CreateShieldWall RemoveShieldWall + & itUse + .~ defaultrUse + { _useAim = + AimParams + { _aimWeight = 5 + , _aimRange = 0 + , _aimZoom = ItZoom 20 0.2 1 + , _aimStance = TwoHandFlat + , _aimHandlePos = 0 + , _aimMuzPos = 0 + } + } + & itInvSize .~ 3 + & itType . iyBase .~ HELD FLATSHIELD shieldWall :: Int -> Wall -shieldWall crid = defaultWall - {_wlColor = yellow - ,_wlOpacity = SeeAbove - ,_wlPathable = True - ,_wlWalkable = True - ,_wlFireThrough = True - ,_wlReflect = True - ,_wlUnshadowed = False - ,_wlRotateTo = False - ,_wlStructure = CreaturePart crid -- shieldWallDamage - } +shieldWall crid = + defaultWall + { _wlColor = yellow + , _wlOpacity = SeeAbove + , _wlPathable = True + , _wlWalkable = True + , _wlFireThrough = True + , _wlReflect = True + , _wlUnshadowed = False + , _wlRotateTo = False + , _wlStructure = CreaturePart crid -- shieldWallDamage + } -- TODO the reflection should be controled by the particle --shieldWallDamage :: Damage -> Wall -> Int -> World -> World --shieldWallDamage dm _ crid w = case _dmType dm of ----- Lasering -> w +---- Lasering -> w -- _ | isMovementDam dm -> w & creatures . ix crid . crState . crDamage .:~ dm -- _ -> w createShieldWall :: Item -> Creature -> World -> World -createShieldWall it cr w = case _ieMID $ _itEffect it of - Nothing -> let (wlid,w') = createWall ((shieldWall crid) {_wlLine = wlline,_wlID = wlid}) w - in w' & cWorld . creatures . ix crid . crInv . ix invid . itEffect . ieMID ?~ wlid +createShieldWall it cr w = case it ^? itEffect . ieMID . _Just of + Nothing -> + let (wlid, w') = createWall ((shieldWall crid){_wlLine = wlline, _wlID = wlid}) w + in w' & cWorld . creatures . ix crid . crInv . ix invid . itEffect . ieMID ?~ wlid Just wid -> moveWallID wid wlline w where invid = fromJust $ _itID it crid = _crID cr - wlline = (a,b) + wlline = (a, b) crdirv = unitVectorAtAngle $ _crDir cr crpos = _crPos cr rad = _crRad cr + 2 a = crpos +.+ rad *.* crdirv -.- 10 *.* therot crdirv b = crpos +.+ rad *.* crdirv +.+ 10 *.* therot crdirv - therot | crIsAiming cr = vNormal - | otherwise = rotateV (twoFlatHRot cr) . vNormal + therot + | crIsAiming cr = vNormal + | otherwise = rotateV (twoFlatHRot cr) . vNormal + removeShieldWall :: Item -> Creature -> World -> World removeShieldWall it cr w = case _ieMID $ _itEffect it of Nothing -> w - Just wid -> w & deleteWallID wid - & cWorld . creatures . ix crid . crInv . ix invid . itEffect . ieMID .~ Nothing + Just wid -> + w & deleteWallID wid + & cWorld . creatures . ix crid . crInv . ix invid . itEffect . ieMID .~ Nothing where crid = _crID cr invid = fromJust (_itID it) -effectOnOffHeld - :: ItInvEffect -- ^ effect when held - -> ItInvEffect -- ^ effect when not held - -> ItEffect -effectOnOffHeld f f' = ItInvEffectID - { _ieInv = OnOffHeldEffect f f' - , _ieMID = Nothing - } +effectOnOffHeld :: + -- | effect when held + ItInvEffect -> + -- | effect when not held + ItInvEffect -> + ItEffect +effectOnOffHeld f f' = + ItInvEffectID + { _ieInv = OnOffHeldEffect f f' + , _ieMID = Nothing + } -{- | Increases speed, reduces friction, cannot only move forwards. -} +-- | Increases speed, reduces friction, cannot only move forwards. jetPack :: Item -jetPack = defaultEquipment - { _itEffect = NoItEffect - , _itID = Nothing - } & itUse . eqEq . eqSite .~ GoesOnBack - & itType . iyBase .~ EQUIP JETPACK +jetPack = + defaultEquipment + { _itEffect = NoItEffect + , _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnBack + & itType . iyBase .~ EQUIP JETPACK brainHat :: Item -brainHat = defaultEquipment - { _itEffect = NoItEffect - , _itID = Nothing - } - & itUse . eqEq . eqSite .~ GoesOnHead - & itType . iyBase .~ EQUIP BRAINHAT +brainHat = + defaultEquipment + { _itEffect = NoItEffect + , _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnHead + & itType . iyBase .~ EQUIP BRAINHAT + hat :: Item -hat = defaultEquipment - { _itEffect = NoItEffect - , _itID = Nothing - } - & itUse . eqEq . eqSite .~ GoesOnHead - & itType . iyBase .~ EQUIP HAT +hat = + defaultEquipment + { _itEffect = NoItEffect + , _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnHead + & itType . iyBase .~ EQUIP HAT headLamp1 :: Item -headLamp1 = defaultEquipment - { _itEffect = NoItEffect - , _itID = Nothing - } - & itUse . eqEq . eqUse .~ EHeadLamp --createHeadLamp - & itUse . eqEq . eqSite .~ GoesOnHead - & itType . iyBase .~ EQUIP HEADLAMP1 -headLamp :: Item -headLamp = defaultEquipment - { _itEffect = NoItEffect - , _itID = Nothing - } - & itUse . eqEq . eqUse .~ EHeadLamp --createHeadLamp - & itUse . eqEq . eqSite .~ GoesOnHead - & itType . iyBase .~ EQUIP HEADLAMP +headLamp1 = + defaultEquipment + { _itEffect = NoItEffect + , _itID = Nothing + } + & itUse . eqEq . eqUse .~ EHeadLamp --createHeadLamp + & itUse . eqEq . eqSite .~ GoesOnHead + & itType . iyBase .~ EQUIP HEADLAMP1 +headLamp :: Item +headLamp = + defaultEquipment + { _itEffect = NoItEffect + , _itID = Nothing + } + & itUse . eqEq . eqUse .~ EHeadLamp --createHeadLamp + & itUse . eqEq . eqSite .~ GoesOnHead + & itType . iyBase .~ EQUIP HEADLAMP createHeadLamp :: Item -> Creature -> World -> World -createHeadLamp _ cr = cWorld . tempLightSources .:~ tlsTimeRadColPos 1 200 0.7 - ((_crPos cr `v2z` 0) +.+.+ rotate3 (_crDir cr) (translatePointToHead cr (V3 5 0 3))) +createHeadLamp _ cr = + cWorld . tempLightSources + .:~ tlsTimeRadColPos + 1 + 200 + 0.7 + ((_crPos cr `v2z` 0) +.+.+ rotate3 (_crDir cr) (translatePointToHead cr (V3 5 0 3))) powerLegs :: Item -powerLegs = defaultEquipment - { _itEffect = NoItEffect - , _itID = Nothing - } - & itUse . eqEq . eqSite .~ GoesOnLegs - & itType . iyBase .~ EQUIP POWERLEGS +powerLegs = + defaultEquipment + { _itEffect = NoItEffect + , _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnLegs + & itType . iyBase .~ EQUIP POWERLEGS + speedLegs :: Item -speedLegs = powerLegs - & itType . iyBase .~ EQUIP SPEEDLEGS +speedLegs = + powerLegs + & itType . iyBase .~ EQUIP SPEEDLEGS + jumpLegs :: Item -jumpLegs = powerLegs - & itType . iyBase .~ EQUIP JUMPLEGS +jumpLegs = + powerLegs + & itType . iyBase .~ EQUIP JUMPLEGS wristInvisibility :: Item -wristInvisibility = defaultEquipment - { _itID = Nothing - } - & itUse . eqEq . eqSite .~ GoesOnWrist - & itUse . eqEq . eqOnEquip .~ ECamouflage Invisible --overCID (crCamouflage .~ Invisible) - & itUse . eqEq . eqOnRemove .~ ECamouflage FullyVisible --overCID (crCamouflage .~ FullyVisible) - & itType . iyBase .~ EQUIP (INVISIBILITYEQUIPMENT GoesOnWrist) +wristInvisibility = + defaultEquipment + { _itID = Nothing + } + & itUse . eqEq . eqSite .~ GoesOnWrist + & itUse . eqEq . eqOnEquip .~ ECamouflage Invisible --overCID (crCamouflage .~ Invisible) + & itUse . eqEq . eqOnRemove .~ ECamouflage FullyVisible --overCID (crCamouflage .~ FullyVisible) + & itType . iyBase .~ EQUIP (INVISIBILITYEQUIPMENT GoesOnWrist) overCID :: (Creature -> Creature) -> Item -> Creature -> World -> World overCID f _ cr = cWorld . creatures . ix (_crID cr) %~ f diff --git a/src/Dodge/Item/Equipment/Booster.hs b/src/Dodge/Item/Equipment/Booster.hs index 130e92dad..0ae3216ec 100644 --- a/src/Dodge/Item/Equipment/Booster.hs +++ b/src/Dodge/Item/Equipment/Booster.hs @@ -1,84 +1,20 @@ -module Dodge.Item.Equipment.Booster - ( boosterGun - , boostSelfL - ) where -import Dodge.Data -import Dodge.Base +module Dodge.Item.Equipment.Booster ( + boosterGun, +) where + +import Control.Lens +import Dodge.Data.Item import Dodge.Default.Weapon -import Geometry -import qualified IntMapHelp as IM import Picture -import Data.Maybe -import Control.Lens -{- | Move a creature towards the mouse position, with shockwave -} -boostPoint - :: Float -- ^ boost amount - -> Creature - -> World - -> Either Point2 Point2 -boostPoint x cr w = case mayp2 of - Nothing -> Right p1 - Just p2 -> Left $ mvPointTowardAtSpeed r cpos $ fst p2 - where - cpos = _crPos cr - r = 1.5 * _crRad cr - p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos w -.- cpos) - mayp2 = bouncePoint (const True) 1 cpos p1 w - -boostSelfL - :: Float -- ^ boost amount - -> Item - -> Creature - -> World - -> World -boostSelfL x itm cr w = case boostPoint x cr w of - Left p -> crEff p (itConsumption . laLoaded .~ 0) - Right p -> crEff p (itConsumption . laLoaded -~ 1) - where - invid = _ipInvID $ _itPos itm - cid = _crID cr - cpos = _crPos cr - r = _crRad cr - pid = fromMaybe (IM.newKey $ _props (_cWorld w)) - (cr ^? crInv . ix invid . itAttachment . atInt) - crEff p ammoEff = addBoostShockwave pid p (r *.* normalizeV (p -.- cpos)) w - & cWorld . creatures . ix cid %~ - (crPos .~ p) - . (crInv . ix invid %~ - ammoEff - . (itEffect . ieCounter .~ 1) - . (itAttachment .~ AttachInt pid) - ) - -addBoostShockwave - :: Int - -> Point2 - -> Point2 - -> World - -> World -addBoostShockwave pjid p v w = w & cWorld . linearShockwaves %~ - IM.insertWith f pjid thePJ - where - thePJ = LinearShockwave - { _lwPos = p - , _lwID = pjid - , _lwPoints = [(p,v)] - , _lwTimer = maxT - } - f newVal oldVal = newVal & lwPoints %~ (++ _lwPoints oldVal) - -maxT :: Int -maxT = 20 - boosterGun :: Item -boosterGun = defaultLeftItem - { _itInvColor = cyan - , _itConsumption = defaultChargeable - , _itUse = luseInstantNoH LBoost - , _itEffect = resetAttachmentID - } - & itType . iyBase .~ LEFT BOOSTER +boosterGun = + defaultLeftItem + { _itInvColor = cyan + , _itUse = luseInstantNoH LBoost + , _itEffect = resetAttachmentID + } + & itType . iyBase .~ LEFT BOOSTER + resetAttachmentID :: ItEffect resetAttachmentID = ItInvEffect ResetAttachmentEffect 0 - diff --git a/src/Dodge/Item/Location.hs b/src/Dodge/Item/Location.hs index 2edb0e8d7..e0ec1d25a 100644 --- a/src/Dodge/Item/Location.hs +++ b/src/Dodge/Item/Location.hs @@ -30,8 +30,8 @@ getItem itid w = do InInv cid invid -> w ^? cWorld . creatures . ix cid . crInv . ix invid VoidItm -> Nothing -pointToItem :: Applicative f => +pointerToItem :: Applicative f => ItemPos -> (Item -> f Item) -> World -> f World -pointToItem (InInv cid invid) = cWorld . creatures . ix cid . crInv . ix invid -pointToItem (OnFloor flid) = cWorld . floorItems . ix flid . flIt -pointToItem _ = const pure +pointerToItem (InInv cid invid) = cWorld . creatures . ix cid . crInv . ix invid +pointerToItem (OnFloor flid) = cWorld . floorItems . ix flid . flIt +pointerToItem _ = const pure diff --git a/src/Dodge/Item/PassKey.hs b/src/Dodge/Item/PassKey.hs index dc3ea4432..a51758bbe 100644 --- a/src/Dodge/Item/PassKey.hs +++ b/src/Dodge/Item/PassKey.hs @@ -10,7 +10,7 @@ keyCard n = defaultEquipment -- , _itZoom = defaultItZoom , _itInvColor = aquamarine } - & itType . iyBase .~ KEYCARD n + & itType . iyBase .~ HELD (KEYCARD n) latchkey :: Int -> Item latchkey _ = defaultEquipment diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 9ef1bb13e..78a562793 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -55,8 +55,8 @@ sparkGun = teslaGun & itParams . arcSize .~ 10 teslaGun :: Item teslaGun = defaultBatteryGun - & itConsumption . laMax .~ 200 - & itConsumption . laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] + & itUse . heldConsumption . laMax .~ 200 + & itUse . heldConsumption . laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] & itDimension . dimRad .~ 9 & itDimension . dimCenter .~ V3 4 0 0 & itParams .~ teslaParams @@ -91,7 +91,7 @@ lasCircle = lasGun & itType . iyBase .~ HELD LASCIRCLE & itParams . lasColor .~ orange & itParams . lasDamage .~ 2 - & itConsumption . laMax .~ 10000 + & itUse . heldConsumption . laMax .~ 10000 & itUse . rUse .~ HeldLaser --shootLaser & itUse . useDelay .~ NoDelay & itUse . rUse .~ HeldCircleLaser --circleLaser @@ -212,7 +212,7 @@ dualBeam = lasGun -- x' = _lasCycle $ _itParams it lasGun :: Item lasGun = defaultAutoBatteryGun - & itConsumption .~ ( defaultLoadable + & itUse . heldConsumption .~ ( defaultLoadable & laMax .~ 200 & laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] ) @@ -225,7 +225,6 @@ lasGun = defaultAutoBatteryGun } & itTweaks .~ Tweakable { _tweakParams = IM.fromList [(0,lasGunTweak)] - , _tweakSel = 0 } & itDimension . dimRad .~ 10 & itDimension . dimCenter .~ V3 15 0 0 @@ -247,14 +246,13 @@ lasGunTweak = TweakParam } tractorGun :: Item tractorGun = lasGun - & itConsumption .~ + & itUse . heldConsumption .~ ( defaultLoadable & laMax .~ 10000 & laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] ) & itParams .~ Attracting {_attractionPower = 1} & itTweaks .~ Tweakable { _tweakParams = IM.fromList [(0,tractorGunTweak)] - , _tweakSel = 0 } & itUse . rUse .~ HeldTractor --aTractorBeam & itUse . useDelay .~ NoDelay diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 80191085b..1a0d251c1 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -13,7 +13,7 @@ basicBullet = BulletAmmo } defaultBullet :: Bullet defaultBullet = Bullet - { _buState = NormalBulletState + { _buDelayFraction = 1 , _buEffect = DestroyBullet , _buSpawn = BulSpark , _buUpdateMod = NoBulletUpdateMod diff --git a/src/Dodge/Item/Weapon/BulletGun/Cane.hs b/src/Dodge/Item/Weapon/BulletGun/Cane.hs index 7a2f8dfb3..64b58b4e8 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Cane.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Cane.hs @@ -37,8 +37,8 @@ defaultBangCane = & itUse . useAim . aimHandlePos .~ 5 & itUse . useAim . aimMuzPos .~ 15 & itType . iyBase .~ error "undefined bangCane baseitemtype" - & itConsumption . laMax .~ 1 - & itConsumption . laCycle .~ [loadPartialInsert 10 1] + & itUse . heldConsumption . laMax .~ 1 + & itUse . heldConsumption . laCycle .~ [loadPartialInsert 10 1] volleyGun :: Int -> Item volleyGun i = @@ -51,7 +51,7 @@ volleyGun i = & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} & itUse . useAim . aimHandlePos .~ 5 & itUse . useAim . aimMuzPos .~ 15 - & itConsumption . laMax .~ i + & itUse . heldConsumption . laMax .~ i & itParams .~ BulletShooter { _muzVel = 0.8 @@ -79,8 +79,8 @@ rifle = defaultBangCane & itUse . useAim . aimStance .~ TwoHandTwist & itType . iyBase .~ HELD RIFLE - & itConsumption . laMax .~ 1 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 5, loadPrime 5] + & itUse . heldConsumption . laMax .~ 1 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 5, loadPrime 5] & itUse . useAim . aimWeight .~ 6 & itUse . useAim . aimRange .~ 1 & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomFac = 2} @@ -91,8 +91,8 @@ repeater = rifle & itType . iyModules . at ModRifleMag ?~ EMPTYMODULE & itType . iyBase .~ HELD REPEATER - & itConsumption . laCycle .~ [loadEject 20, loadInsert 20, loadPrime 20] - & itConsumption . laMax .~ 15 + & itUse . heldConsumption . laCycle .~ [loadEject 20, loadInsert 20, loadPrime 20] + & itUse . heldConsumption . laMax .~ 15 autoRifle :: Item autoRifle = @@ -120,21 +120,20 @@ miniGunUse i = miniGunX :: Int -> Item miniGunX i = defaultAutoGun - { _itConsumption = - defaultBulletLoadable - { _laMax = 1500 - , _laLoaded = 1500 - } - & laCycle .~ [loadEject 40, loadInsert 40, loadPrime 40] - , _itUse = + { _itUse = miniGunUse i & useDelay .~ WarmUpNoDelay{_warmTime = 0, _warmMax = 100} & useAim . aimWeight .~ 6 & useAim . aimRange .~ 1 & useAim . aimStance .~ TwoHandTwist & useAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} - , -- , _itFloorPict = miniGunPictItem - _itParams = + & heldConsumption + .~ defaultBulletLoadable + { _laMax = 1500 + , _laLoaded = 1500 + } + & heldConsumption . laCycle .~ [loadEject 40, loadInsert 40, loadPrime 40] + , _itParams = BulletShooter { _muzVel = 1 , _rifling = 0.9 diff --git a/src/Dodge/Item/Weapon/BulletGun/Rod.hs b/src/Dodge/Item/Weapon/BulletGun/Rod.hs index c0b19f4e2..c8a6dd195 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Rod.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Rod.hs @@ -30,8 +30,8 @@ bangRod = defaultBulletWeapon & itUse . useMods .~ BangRodMod & itDimension . dimRad .~ 12 & itDimension . dimCenter .~ V3 5 0 0 - & itConsumption . laMax .~ 1 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 10 , loadPrime 5] + & itUse . heldConsumption . laMax .~ 1 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 10 , loadPrime 5] & itType . iyBase .~ HELD BANGROD & itUse . useAim . aimWeight .~ 8 & itUse . useAim . aimRange .~ 1 @@ -39,7 +39,7 @@ bangRod = defaultBulletWeapon & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} & itUse . useAim . aimHandlePos .~ 5 & itUse . useAim . aimMuzPos .~ 30 - & itConsumption . laAmmoType .~ hvBullet + & itUse . heldConsumption . laAmmoType .~ hvBullet elephantGun :: Item elephantGun = bangRod & itType . iyBase .~ HELD ELEPHANTGUN @@ -51,7 +51,7 @@ elephantGun = bangRod amr :: Item amr = elephantGun & itType . iyBase .~ HELD AMR - & itConsumption . laMax .~ 15 + & itUse . heldConsumption . laMax .~ 15 autoAmr :: Item autoAmr = amr @@ -77,7 +77,7 @@ machineGun = bangRod & itUse . useAim . aimStance .~ TwoHandTwist & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} & itUse . useDelay .~ VariableRate {_rateMax = 25, _rateMaxMax = 24, _rateMinMax = 7, _rateTime = 0} - & itConsumption . laMax .~ 100 - & itConsumption . laCycle .~ [loadEject 10, loadInsert 40 , loadPrime 10] + & itUse . heldConsumption . laMax .~ 100 + & itUse . heldConsumption . laCycle .~ [loadEject 10, loadInsert 40 , loadPrime 10] & itInvSize .~ 3 & itParams. torqueAfter .~ 0.2 -- not sure if this is necessary? diff --git a/src/Dodge/Item/Weapon/BulletGun/Stick.hs b/src/Dodge/Item/Weapon/BulletGun/Stick.hs index e18efc370..c9ac27d95 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Stick.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Stick.hs @@ -36,15 +36,15 @@ bangStick i = defaultBulletWeapon & itType . iyBase .~ HELD (BANGSTICK i) & itUse . useAim . aimHandlePos .~ 5 & itUse . useAim . aimMuzPos .~ 10 - & itConsumption . laMax .~ i - & itConsumption . laCycle .~ [loadPartialInsert 10 1] + & itUse . heldConsumption . laMax .~ i + & itUse . heldConsumption . laCycle .~ [loadPartialInsert 10 1] baseStickSpread :: Float baseStickSpread = 0.2 revolver :: Item revolver = pistol - & itConsumption .~ + & itUse . heldConsumption .~ (defaultBulletLoadable & laMax .~ 6 & laCycle .~ [loadPartialInsert 10 1] ) @@ -52,7 +52,7 @@ revolver = pistol pistol :: Item pistol = bangStick 1 - & itConsumption .~ ( defaultBulletLoadable + & itUse . heldConsumption .~ ( defaultBulletLoadable & laMax .~ 15 & laCycle .~ [loadEject 5, loadInsert 5 , loadPrime 5] ) & itUse . useDelay . rateMax .~ 6 @@ -89,5 +89,5 @@ revolverX :: Int -> Item revolverX i = revolver & itUse . useDelay . rateMax .~ 8 & itUse . useMods .~ RevolverXMod - & itConsumption . laMax .~ i * 6 + & itUse . heldConsumption . laMax .~ i * 6 & itType . iyBase .~ HELD (REVOLVERX i) diff --git a/src/Dodge/Item/Weapon/BulletGuns.hs b/src/Dodge/Item/Weapon/BulletGuns.hs index 736fc8bb4..04f6266a5 100644 --- a/src/Dodge/Item/Weapon/BulletGuns.hs +++ b/src/Dodge/Item/Weapon/BulletGuns.hs @@ -82,13 +82,13 @@ bangCone = defaultBulletWeapon & itUse . useAim . aimHandlePos .~ 5 & itUse . useAim . aimMuzPos .~ 15 & itType . iyBase .~ HELD BANGCONE - & itConsumption . laMax .~ 5 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 20 , loadPrime 5] + & itUse . heldConsumption . laMax .~ 5 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 20 , loadPrime 5] blunderbuss :: Item blunderbuss = bangCone - & itConsumption . laMax .~ 25 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 30 , loadPrime 5] + & itUse . heldConsumption . laMax .~ 25 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 30 , loadPrime 5] & itUse . useAim . aimStance .~ TwoHandTwist & itUse . useAim . aimWeight .~ 6 & itUse . useAim . aimHandlePos .~ 5 @@ -97,8 +97,8 @@ blunderbuss = bangCone grapeCannon :: Int -> Item grapeCannon i = blunderbuss & itType . iyBase .~ HELD (GRAPECANNON i) - & itConsumption . laMax .~ 25 + 25 * i - & itConsumption . laCycle .~ [loadEject 5, loadInsert (30 + i * 10) , loadPrime 5] + & itUse . heldConsumption . laMax .~ 25 + 25 * i + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert (30 + i * 10) , loadPrime 5] & itParams . recoil .~ (150 + fromIntegral i * 50) & itParams . torqueAfter .~ (0.1 + 0.2 * fromIntegral i) & itParams . randomOffset .~ (12 + 4 * fromIntegral i) diff --git a/src/Dodge/Item/Weapon/Drone.hs b/src/Dodge/Item/Weapon/Drone.hs index 64850ca81..e765fee87 100644 --- a/src/Dodge/Item/Weapon/Drone.hs +++ b/src/Dodge/Item/Weapon/Drone.hs @@ -16,8 +16,8 @@ droneLauncher = defaultWeapon & itUse . useAim . aimWeight .~ 8 & itUse . useAim . aimRange .~ 0.5 & itUse . useAim . aimStance .~ TwoHandTwist - & itConsumption . laAmmoType .~ DroneAmmo { _amString = "LASDRONE" } - & itConsumption . laMax .~ 2 + & itUse . heldConsumption . laAmmoType .~ DroneAmmo { _amString = "LASDRONE" } + & itUse . heldConsumption . laMax .~ 2 & itType . iyBase .~ HELD DRONELAUNCHER lasDronesPic :: Item -> SPic diff --git a/src/Dodge/Item/Weapon/FractionLoaded.hs b/src/Dodge/Item/Weapon/FractionLoaded.hs index 5f516feba..a21b7882e 100644 --- a/src/Dodge/Item/Weapon/FractionLoaded.hs +++ b/src/Dodge/Item/Weapon/FractionLoaded.hs @@ -6,17 +6,17 @@ import Dodge.Data ---- this shouldn't really be used loadedAmmo :: Item -> Int -loadedAmmo = _laLoaded . _itConsumption +loadedAmmo = _laLoaded . _heldConsumption . _itUse -- | _laTransfer (_itConsumption it) == NoTransfer = _laLoaded (_itConsumption it) -- | otherwise = 0 fractionLoadedAmmo :: Item -> Float fractionLoadedAmmo it = fromIntegral (loadedAmmo it) / fromIntegral (itmaxammo it) where - itmaxammo = _laMax . _itConsumption + itmaxammo = _laMax . _heldConsumption . _itUse fractionLoadedAmmo2 :: Item -> Float fractionLoadedAmmo2 it = 1 - (1 - fromIntegral (loadedAmmo it) / fromIntegral (itMaxAmmo it))**2 where - itMaxAmmo = _laMax . _itConsumption + itMaxAmmo = _laMax . _heldConsumption . _itUse diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 2453dba25..b5f3dd83e 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -1,110 +1,122 @@ -module Dodge.Item.Weapon.Launcher - ( launcher - , launcherX - , remoteLauncher - , fireTrackingShell - , explodeRemoteRocket - ) where +module Dodge.Item.Weapon.Launcher ( + launcher, + launcherX, + remoteLauncher, + fireTrackingShell, + explodeRemoteRocket, +) where + +import Control.Lens import Dodge.Data -import Dodge.Projectile.Create -import Dodge.Payload -import Dodge.Reloading.Action import Dodge.Default.Weapon import Dodge.Item.Location +import Dodge.Payload +import Dodge.Projectile.Create +import Dodge.Reloading.Action import Geometry import qualified IntMapHelp as IM -import Control.Lens - launcher :: Item -launcher = defaultWeapon - { _itConsumption = defaultLoadable - & laAmmoType .~ ProjectileAmmo - { _amPayload = ExplosionPayload - , _amString = "EXPLOSIVE SHELL" - , _amPjDraw = DrawShell - , _amPjCreation = CreateShell - } - & laMax .~ 1 - & laLoaded .~ 1 - & laCycle .~ [loadEject 30, loadInsert 30, loadPrime 10] - , _itParams = ShellLauncher - { _shellSpinDrag = 1 - , _shellSpinAmount = 2 - , _shellThrustDelay = 20 +launcher = + defaultWeapon + { _itParams = + ShellLauncher + { _shellSpinDrag = 1 + , _shellSpinAmount = 2 + , _shellThrustDelay = 20 + } + , _itTweaks = + Tweakable + { _tweakParams = basicAmPjMoves + } + , _itInvSize = 3 } - , _itTweaks = Tweakable - { _tweakSel = 0 - , _tweakParams = basicAmPjMoves - } - , _itInvSize = 3 - } - & itDimension . dimRad .~ 9 - & itDimension . dimCenter .~ V3 10 0 0 - & itUse . useDelay . rateMax .~ 20 - & itUse . rUse .~ HeldPJCreation --usePjCreation - & itUse . useMods .~ LauncherMod - & itUse . useAim . aimWeight .~ 8 - & itUse . useAim . aimRange .~ 0.5 - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 20 - & itType . iyBase .~ HELD LAUNCHER - & itType . iyModules . at ModLauncherHoming ?~ EMPTYMODULE + & itDimension . dimRad .~ 9 + & itDimension . dimCenter .~ V3 10 0 0 + & itUse . useDelay . rateMax .~ 20 + & itUse . rUse .~ HeldPJCreation --usePjCreation + & itUse . useMods .~ LauncherMod + & itUse . useAim . aimWeight .~ 8 + & itUse . useAim . aimRange .~ 0.5 + & itUse . useAim . aimStance .~ TwoHandTwist + & itUse . useAim . aimHandlePos .~ 5 + & itUse . useAim . aimMuzPos .~ 20 + & itUse . heldConsumption . laAmmoType .~ ProjectileAmmo + { _amPayload = ExplosionPayload + , _amString = "EXPLOSIVE SHELL" + , _amPjDraw = DrawShell + , _amPjCreation = CreateShell + } + & itUse . heldConsumption . laMax .~ 1 + & itUse . heldConsumption . laLoaded .~ 1 + & itUse . heldConsumption . laCycle .~ [loadEject 30, loadInsert 30, loadPrime 10] + & itType . iyBase .~ HELD LAUNCHER + & itType . iyModules . at ModLauncherHoming ?~ EMPTYMODULE launcherX :: Int -> Item -launcherX i = launcher - & itType . iyBase .~ HELD (LAUNCHERX i) - & itConsumption . laMax .~ i - & itConsumption . laLoaded .~ i - & itUse . rUse .~ HeldPJCreationX i - & itUse . useMods .~ LauncherXMod i +launcherX i = + launcher + & itType . iyBase .~ HELD (LAUNCHERX i) + & itUse . heldConsumption . laMax .~ i + & itUse . heldConsumption . laLoaded .~ i + & itUse . rUse .~ HeldPJCreationX i + & itUse . useMods .~ LauncherXMod i basicAmPjMoves :: IM.IntMap TweakParam -basicAmPjMoves = IM.fromList . zip [0..] $ - [spinDrag - ,spinStart - ,thrustParam - ] +basicAmPjMoves = + IM.fromList . zip [0 ..] $ + [ spinDrag + , spinStart + , thrustParam + ] + spinDrag :: TweakParam -spinDrag = TweakParam - { _tweakType = TweakSpinDrag - , _tweakVal = 1 - , _tweakMax = 5 - } +spinDrag = + TweakParam + { _tweakType = TweakSpinDrag + , _tweakVal = 1 + , _tweakMax = 5 + } + spinStart :: TweakParam -spinStart = TweakParam - { _tweakType = TweakSpinAmount - , _tweakVal = 2 - , _tweakMax = 5 - } +spinStart = + TweakParam + { _tweakType = TweakSpinAmount + , _tweakVal = 2 + , _tweakMax = 5 + } + thrustParam :: TweakParam -thrustParam = TweakParam - { _tweakType = TweakThrustDelay - , _tweakVal = 1 - , _tweakMax = 5 - } +thrustParam = + TweakParam + { _tweakType = TweakThrustDelay + , _tweakVal = 1 + , _tweakMax = 5 + } remoteLauncher :: Item -remoteLauncher = launcher - & itType . iyBase .~ HELD REMOTELAUNCHER - & itUse . rUse .~ HeldFireRemoteShell --fireRemoteShell - & itScope .~ RemoteScope (V2 0 0) 1 True - & itConsumption . laAmmoType . amPjDraw .~ DrawRemoteShell +remoteLauncher = + launcher + & itType . iyBase .~ HELD REMOTELAUNCHER + & itUse . rUse .~ HeldFireRemoteShell --fireRemoteShell + & itScope .~ RemoteScope (V2 0 0) 1 True + & itUse . heldConsumption . laAmmoType . amPjDraw .~ DrawRemoteShell + -- TODO consider allowing tweaking rocket speed -explodeRemoteRocket - :: Int -- ^ Item id - -> Int -- ^ Projectile id - -> World - -> World -explodeRemoteRocket itid pjid w = w - & cWorld . projectiles . ix pjid . prjUpdates .~ [PJRetireRemote itid 30 pjid] - & cWorld . projectiles . ix pjid . prjDraw .~ DrawBlankProjectile - & itPoint . itUse . rUse .~ HeldDoNothing - & usePayload (_prjPayload thepj) (_prjPos thepj) - where - itPoint = pointToItem $ _itemPositions (_cWorld w) IM.! itid +explodeRemoteRocket :: + -- | Item id + Int -> + -- | Projectile id + Int -> + World -> + World +explodeRemoteRocket itid pjid w = + w + & cWorld . projectiles . ix pjid . prjUpdates .~ [PJRetireRemote itid 30 pjid] + & cWorld . projectiles . ix pjid . prjDraw .~ DrawBlankProjectile + & itPoint . itUse . rUse .~ HeldDoNothing + & usePayload (_prjPayload thepj) (_prjPos thepj) + where + itPoint = pointerToItem $ _itemPositions (_cWorld w) IM.! itid thepj = _projectiles (_cWorld w) IM.! pjid - - diff --git a/src/Dodge/Item/Weapon/Remote.hs b/src/Dodge/Item/Weapon/Remote.hs index c3c704de1..4b7f4a483 100644 --- a/src/Dodge/Item/Weapon/Remote.hs +++ b/src/Dodge/Item/Weapon/Remote.hs @@ -1,5 +1,5 @@ module Dodge.Item.Weapon.Remote - ( pointToItem + ( pointerToItem , setRemoteScope , setRemoteBombScope ) where diff --git a/src/Dodge/Item/Weapon/SprayGuns.hs b/src/Dodge/Item/Weapon/SprayGuns.hs index 62720e1fe..7e228ad1d 100644 --- a/src/Dodge/Item/Weapon/SprayGuns.hs +++ b/src/Dodge/Item/Weapon/SprayGuns.hs @@ -1,95 +1,107 @@ -module Dodge.Item.Weapon.SprayGuns - ( poisonSprayer - , flameSpitter - , blowTorch - , flameThrower - , flameTorrent - , flameWall - ) where +module Dodge.Item.Weapon.SprayGuns ( + poisonSprayer, + flameSpitter, + blowTorch, + flameThrower, + flameTorrent, + flameWall, +) where + import Dodge.Data -import Dodge.Reloading.Action import Dodge.Default +import Dodge.Reloading.Action import Geometry import LensHelp poisonSprayer :: Item -poisonSprayer = flameThrower - & itType . iyBase .~ HELD POISONSPRAYER - & itConsumption . laAmmoType .~ GasAmmo - { _amString = "POISONGAS" - , _amCreateGas = CreatePoisonGas --aGasCloud - } - & itUse . useMods .~ PoisonSprayerMod - +poisonSprayer = + flameThrower + & itType . iyBase .~ HELD POISONSPRAYER + & itUse . heldConsumption . laAmmoType + .~ GasAmmo + { _amString = "POISONGAS" + , _amCreateGas = CreatePoisonGas --aGasCloud + } + & itUse . useMods .~ PoisonSprayerMod + flameSpitter :: Item -flameSpitter = flameThrower - & itType . iyBase .~ HELD FLAMESPITTER - & itConsumption . laMax .~ 10 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 10 , loadPrime 20] - & itParams . sprayNozzles . ix 0 . nzPressure .~ 4 - & itUse . useAim . aimStance .~ OneHand - & itUse . useDelay .~ FixedRate {_rateMax =12,_rateTime = 0} - & itUse . useMods .~ FlameSpitterMod +flameSpitter = + flameThrower + & itType . iyBase .~ HELD FLAMESPITTER + & itUse . heldConsumption . laMax .~ 10 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 10, loadPrime 20] + & itParams . sprayNozzles . ix 0 . nzPressure .~ 4 + & itUse . useAim . aimStance .~ OneHand + & itUse . useDelay .~ FixedRate{_rateMax = 12, _rateTime = 0} + & itUse . useMods .~ FlameSpitterMod flameTorrent :: Item -flameTorrent = flameThrower - & itType . iyBase .~ HELD FLAMETORRENT - & itUse . useAim . aimZoom .~ defaultItZoom - & itParams . sprayNozzles . ix 0 %~ - ( (nzPressure .~ 10) - . (nzMaxWalkAngle .~ 1.5) - . (nzWalkSpeed .~ 0.05) - ) +flameTorrent = + flameThrower + & itType . iyBase .~ HELD FLAMETORRENT + & itUse . useAim . aimZoom .~ defaultItZoom + & itParams . sprayNozzles . ix 0 + %~ ( (nzPressure .~ 10) + . (nzMaxWalkAngle .~ 1.5) + . (nzWalkSpeed .~ 0.05) + ) blowTorch :: Item -blowTorch = flameThrower - & itType . iyBase .~ HELD BLOWTORCH +blowTorch = + flameThrower + & itType . iyBase .~ HELD BLOWTORCH + flameWall :: Item -flameWall = flameThrower - & itType . iyBase .~ HELD FLAMEWALL - & itParams . sprayNozzles .~ zipWith makeNozzle [0,0.6,-0.6] [2,2.5,2.5] +flameWall = + flameThrower + & itType . iyBase .~ HELD FLAMEWALL + & itParams . sprayNozzles .~ zipWith makeNozzle [0, 0.6, -0.6] [2, 2.5, 2.5] where - makeNozzle dir pres = Nozzle - { _nzPressure = pres - , _nzDir = dir - , _nzMaxWalkAngle = 0 - , _nzWalkSpeed = 0 - , _nzCurrentWalkAngle = 0 - , _nzLength = 20 - } + makeNozzle dir pres = + Nozzle + { _nzPressure = pres + , _nzDir = dir + , _nzMaxWalkAngle = 0 + , _nzWalkSpeed = 0 + , _nzCurrentWalkAngle = 0 + , _nzLength = 20 + } flameThrower :: Item -flameThrower = defaultAutoGun - { _itConsumption = defaultLoadable - & laMax .~ 250 - & laAmmoType .~ GasAmmo - {_amString = "FLAME" - ,_amCreateGas = CreateFlame --aFlame - } - & laCycle .~ [loadEject 5, loadInsert 10 , loadPrime 20] - , _itParams = Sprayer - { _sprayNozzles = - [ Nozzle - { _nzPressure = 4 - , _nzDir = 0 - , _nzMaxWalkAngle = 0.2 - , _nzWalkSpeed = 0.01 - , _nzCurrentWalkAngle = 0 - , _nzLength = 10 +flameThrower = + defaultAutoGun + { _itParams = + Sprayer + { _sprayNozzles = + [ Nozzle + { _nzPressure = 4 + , _nzDir = 0 + , _nzMaxWalkAngle = 0.2 + , _nzWalkSpeed = 0.01 + , _nzCurrentWalkAngle = 0 + , _nzLength = 10 + } + ] } - ] } - } - & itDimension . dimRad .~ 7 - & itDimension . dimCenter .~ V3 9 0 0 - & itUse . rUse .~ HeldOverNozzlesUseGasParams -- overNozzles useGasParams - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ FlameThrowerMod - & itUse . useAim . aimWeight .~ 5 - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomMax = 5, _itZoomMin = 1.5} - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 0 - & itUse . useAim . aimMuzPos .~ 18 - & itType . iyBase .~ HELD FLAMETHROWER - - + & itDimension . dimRad .~ 7 + & itDimension . dimCenter .~ V3 9 0 0 + & itUse . rUse .~ HeldOverNozzlesUseGasParams -- overNozzles useGasParams + & itUse . useDelay .~ NoDelay + & itUse . useMods .~ FlameThrowerMod + & itUse . useAim . aimWeight .~ 5 + & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomMax = 5, _itZoomMin = 1.5} + & itUse . useAim . aimStance .~ TwoHandTwist + & itUse . useAim . aimHandlePos .~ 0 + & itUse . useAim . aimMuzPos .~ 18 + & itUse . heldConsumption + .~ ( defaultLoadable + & laMax .~ 250 + & laAmmoType + .~ GasAmmo + { _amString = "FLAME" + , _amCreateGas = CreateFlame --aFlame + } + & laCycle .~ [loadEject 5, loadInsert 10, loadPrime 20] + ) + & itType . iyBase .~ HELD FLAMETHROWER diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 5d4bf2da8..249395c31 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -141,7 +141,7 @@ ammoCheckI eff itm cr w | _laLoaded ic <= 0 || not (_laPrimed ic) = w | otherwise = eff itm cr $ w & cWorld . creatures . ix (_crID cr) %~ crCancelReloading where - ic = _itConsumption itm + ic = _heldConsumption $ _itUse itm -- combined ammo and hammer check: want to be able to auto-reload even if the -- hammer is down? @@ -152,13 +152,13 @@ ammoHammerCheck eff it cr w Just HammerUp -> eff it cr $ w & cWorld . creatures . ix (_crID cr) %~ crCancelReloading _ -> w where - ic = _itConsumption it + ic = _heldConsumption $ _itUse it itUseCharge :: Int -> Item -> Item -itUseCharge x = itConsumption . arLoaded %~ (max 0 . subtract x) +itUseCharge x = itUse . leftConsumption . arLoaded %~ (max 0 . subtract x) itUseAmmo :: Int -> Item -> Item -itUseAmmo x = itConsumption . laLoaded %~ (max 0 . subtract x) +itUseAmmo x = itUse . heldConsumption . laLoaded %~ (max 0 . subtract x) {- | Fires at an increasing rate. Has different effect after first fire. @@ -295,14 +295,14 @@ withSidePushAfterI maxSide eff item cr w = over (cWorld . creatures . ix cid) pu (pushAmount, g) = randomR (-maxSide,maxSide) $ _randGen w useAllAmmo :: ChainEffect useAllAmmo eff item cr = eff item cr - . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itConsumption . laLoaded .~ 0) + . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded .~ 0) useAmmoUpTo :: Int -> ChainEffect useAmmoUpTo amAmount eff item cr = eff item cr - . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itConsumption . laLoaded + . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded %~ (max 0 . subtract amAmount)) useAmmoAmount :: Int -> ChainEffect useAmmoAmount amAmount eff item cr = eff item cr - . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itConsumption . laLoaded -~ amAmount) + . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded -~ amAmount) {- | Applies a world effect after an item use cooldown check. -} useTimeCheck :: ChainEffect @@ -316,7 +316,7 @@ useTimeCheck f item cr w = case item ^? itUse . useDelay . rateTime of {- | Applies a world effect after a hammer position check. -} hammerCheckI :: ChainEffect hammerCheckI f it cr w = case it ^? itUse . useHammer of - Just HammerUp | _laPrimed (_itConsumption it) + Just HammerUp | _laPrimed (_heldConsumption (_itUse it)) -> f it cr w _ -> w @@ -335,7 +335,7 @@ ammoUseCheck f item cr w pointerToItem = cWorld . creatures . ix cid . crInv . ix itRef fireCondition = crWeaponReady cr && _rateTime (_useDelay (_itUse item)) == 0 - && _laLoaded (_itConsumption item) > 0 + && _laLoaded (_heldConsumption (_itUse item)) > 0 -- reloadCondition = _laLoaded (_itConsumption item) == 0 {- | Applies a world effect after a hammer position check. Arbitrary inventory position. -} @@ -366,7 +366,7 @@ shootL f item cr w invid = _ipInvID $ _itPos item pointerToItem = cWorld . creatures . ix cid . crInv . ix invid fireCondition = _rateTime (_useDelay (_itUse item)) == 0 - && _arLoaded (_itConsumption item) > 0 + && _arLoaded (_leftConsumption (_itUse item)) > 0 -- reloadCondition = _laLoaded (_itConsumption item) == 0 withItem :: (Item -> ChainEffect) -> ChainEffect withItem g f it = g it f it @@ -541,7 +541,7 @@ spreadLoaded eff item cr w = foldr f w dirs dirs = subtract cd . (spread *) . fromIntegral <$> [0 .. numBulLoaded - 1] f dir = eff item (cr & crDir +~ dir) spread = _spreadAngle . _brlSpread . _gunBarrels $ _itParams item - numBulLoaded = _laLoaded $ _itConsumption item + numBulLoaded = _laLoaded $ _heldConsumption (_itUse item) sideEffectOnFrame :: Int -> (Item -> Creature -> WdWd) @@ -571,7 +571,7 @@ duplicateLoaded :: ChainEffect duplicateLoaded eff it cr w = foldr f w [1..numBul] where f _ = eff it cr - numBul = _laLoaded $ _itConsumption it + numBul = _laLoaded $ _heldConsumption (_itUse it) duplicateLoadedBarrels :: ChainEffect duplicateLoadedBarrels eff item cr w = foldr f w poss @@ -582,7 +582,7 @@ duplicateLoadedBarrels eff item cr w = foldr f w poss poss = map (rotateV (_crDir cr) . V2 0 . (*5) . (+ cp) . fromIntegral) [0 .. numBul - 1] f pos = eff item (cr & crPos %~ (+.+ pos)) numBar = _brlNum . _gunBarrels $ _itParams item - numBul = _laLoaded $ _itConsumption item + numBul = _laLoaded $ _heldConsumption (_itUse item) duplicateOffsetsFocus :: [Float] -> ChainEffect duplicateOffsetsFocus xs eff item cr w = foldr f w poss diff --git a/src/Dodge/Item/Weapon/Utility.hs b/src/Dodge/Item/Weapon/Utility.hs index 4617ffcaf..ff2e15ed8 100644 --- a/src/Dodge/Item/Weapon/Utility.hs +++ b/src/Dodge/Item/Weapon/Utility.hs @@ -1,60 +1,67 @@ module Dodge.Item.Weapon.Utility where -import Dodge.Data + +import Control.Lens +import Data.Maybe import Dodge.Base.Coordinate +import Dodge.Data import Dodge.Default import Dodge.Item.Weapon.ExtraEffect import Dodge.Wall.ForceField import Dodge.Wall.Move import Geometry -import Picture import qualified IntMapHelp as IM +import Picture import Shape import ShapePicture -import Data.Maybe -import Control.Lens rewindGun :: Item -rewindGun = defaultLeftItem - { _itInvColor = cyan - , _itConsumption = ChargeableAmmo - { _wpMaxCharge = 250 - , _wpCharge = 0 +rewindGun = + defaultLeftItem + { _itInvColor = cyan + , _itEffect = ItRewindEffect RewindEffect -- [] + , _itUse = + defaultlUse + & lUse .~ LRewind --useRewindGun + & eqEq . eqSite .~ GoesOnChest } - , _itEffect = ItRewindEffect RewindEffect-- [] - , _itUse = defaultlUse - & lUse .~ LRewind --useRewindGun - & eqEq . eqSite .~ GoesOnChest - } - & itType . iyBase .~ LEFT REWINDER + & itType . iyBase .~ LEFT REWINDER + & itUse . leftConsumption + .~ ChargeableAmmo + { _wpMaxCharge = 250 + , _wpCharge = 0 + } -- needs to shift this item to the current inventory slot shrinkGun :: Item -shrinkGun = defaultLeftItem - {_itUse = defaultlUse & lUse .~ LShrink -- hammerCheckL useShrinkGun --- , _itFloorPict = shrinkGunPic - , _itAttachment = AttachBool True - } - & itType . iyBase .~ LEFT SHRINKER +shrinkGun = + defaultLeftItem + { _itUse = defaultlUse & lUse .~ LShrink -- hammerCheckL useShrinkGun + -- , _itFloorPict = shrinkGunPic + , _itAttachment = AttachBool True + } + & itType . iyBase .~ LEFT SHRINKER shrinkGunPic :: Item -> SPic shrinkGunPic _ = noPic $ colorSH violet $ upperPrismPoly 5 $ square 5 - blinkGun :: Item -blinkGun = defaultLeftItem - { _itInvColor = cyan - , _itUse = defaultlUse - & lUse .~ LBlink --hammerCheckL (shootL $ const blinkAction) - & eqEq . eqSite .~ GoesOnWrist --- , _itFloorPict = const . noPic . colorSH chartreuse $ upperPrismPoly 2 $ square 2 - } - & itType . iyBase .~ LEFT BLINKER +blinkGun = + defaultLeftItem + { _itInvColor = cyan + , _itUse = + defaultlUse + & lUse .~ LBlink --hammerCheckL (shootL $ const blinkAction) + & eqEq . eqSite .~ GoesOnWrist + -- , _itFloorPict = const . noPic . colorSH chartreuse $ upperPrismPoly 2 $ square 2 + } + & itType . iyBase .~ LEFT BLINKER unsafeBlinkGun :: Item -unsafeBlinkGun = blinkGun - & itType . iyBase .~ LEFT BLINKERUNSAFE - & itUse . lUse .~ LUnsafeBlink --hammerCheckL (shootL $ const unsafeBlinkAction) - & itUse . eqEq . eqViewDist ?~ 400 +unsafeBlinkGun = + blinkGun + & itType . iyBase .~ LEFT BLINKERUNSAFE + & itUse . lUse .~ LUnsafeBlink --hammerCheckL (shootL $ const unsafeBlinkAction) + & itUse . eqEq . eqViewDist ?~ 400 --effectGun :: String -> (Creature -> World -> World) -> Item --effectGun name eff = defaultWeapon @@ -69,34 +76,36 @@ unsafeBlinkGun = blinkGun -- } -- & itType . iyBase .~ AUTOEFFGUN name forceFieldGun :: Item -forceFieldGun = defaultWeapon - { _itConsumption = defaultLoadable & laAmmoType .~ ForceFieldAmmo forceField - , _itTargeting = targetRBPress & tgDraw .~ TargetDistanceDraw - , _itParams = ParamMID Nothing - } - & itUse . rUse .~ HeldForceField --useForceFieldGun - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ AmmoHammerTimeUseOneMod -- this is slightly different +forceFieldGun = + defaultWeapon + & itTargeting .~ (targetRBPress & tgDraw .~ TargetDistanceDraw) + & itParams .~ ParamMID Nothing + & itUse . rUse .~ HeldForceField --useForceFieldGun + & itUse . useDelay .~ NoDelay + & itUse . useMods .~ AmmoHammerTimeUseOneMod -- this is slightly different -- than the list below --[ hammerCheckI , ammoCheckI , useAmmoAmount 1] - & itType . iyBase .~ HELD FORCEFIELDGUN + & itType . iyBase .~ HELD FORCEFIELDGUN + & itUse . heldConsumption .~ (defaultLoadable & laAmmoType .~ ForceFieldAmmo forceField) + -- I believe because the targeting returns to nothing straight after you release -- the rmb, it is possible for this to do nothing -- TODO investigate more and fix useForceFieldGun :: Item -> Creature -> World -> World -useForceFieldGun itm cr w = fromMaybe w $ do +useForceFieldGun itm cr w = fromMaybe w $ do a <- _tgPos $ _itTargeting itm let mwp = mouseWorldPos w b = if dist a mwp < 100 then mwp else a +.+ 100 *.* normalizeV (mwp -.- a) - wlline = (a,b) - return $ w - & cWorld . walls %~ IM.insertWith (\_ x -> x) i forceField {_wlID = i} - & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID (_itPos itm)) . itParams . paramMID ?~ i - & moveWallIDUnsafe i wlline + wlline = (a, b) + return $ + w + & cWorld . walls %~ IM.insertWith (\_ x -> x) i forceField{_wlID = i} + & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID (_itPos itm)) . itParams . paramMID ?~ i + & moveWallIDUnsafe i wlline where i = fromMaybe (IM.newKey (_walls (_cWorld w))) $ itm ^? itParams . paramMID . _Just --- grapGun = defaultGun +-- grapGun = defaultGun -- { _itName = "grapGun" -- , _itIdentity = GrapGun -- , _wpMaxAmmo = 1 diff --git a/src/Dodge/Lampoid.hs b/src/Dodge/Lampoid.hs index 4d892e84d..ebb08867e 100644 --- a/src/Dodge/Lampoid.hs +++ b/src/Dodge/Lampoid.hs @@ -12,6 +12,7 @@ updateLampoid :: Creature -> World -> World updateLampoid cr w = case cr ^?! crType . lampLSID of Nothing -> let i = IM.newKey (_lightSources (_cWorld w)) in w & cWorld . lightSources %~ IM.insert i (lsColPosID lcol (addZ h cpos) i) + & cWorld . creatures . ix (_crID cr) . crType . lampLSID ?~ i Just i | _crHP cr < 0 -> w & explosionFlashAt cpos diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 2515364a0..44b361b48 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -35,10 +35,10 @@ lockRoomKeyItems = ,(const longRoomRunPast, takeOne [HELD SNIPERRIFLE,HELD FLATSHIELD]) ,(const glassLessonRunPast, takeOne [HELD LASGUN]) ,(const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD,HELD FORCEFIELDGUN]) - ,(keyCardRoomRunPast 0, return (KEYCARD 0)) + ,(keyCardRoomRunPast 0, return (HELD $ KEYCARD 0)) ] keyCardRunPastRand :: RandomGen g => [ (Int -> State g (MetaTree Room String) , State g ItemBaseType ) ] -keyCardRunPastRand = [(keyCardRoomRunPast 0, return (KEYCARD 0)) ] +keyCardRunPastRand = [(keyCardRoomRunPast 0, return (HELD $ KEYCARD 0)) ] itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room String))] itemRooms = @@ -76,7 +76,7 @@ itemRooms = [rc [forceFieldGun] ] ) - , (KEYCARD 0 , join $ takeOne + , (HELD $ KEYCARD 0 , join $ takeOne [rc [keyCard 0] ] ) diff --git a/src/Dodge/Luse.hs b/src/Dodge/Luse.hs index 1136904ef..14a6b271f 100644 --- a/src/Dodge/Luse.hs +++ b/src/Dodge/Luse.hs @@ -1,9 +1,13 @@ module Dodge.Luse where -import Dodge.Data -import Dodge.Item.Weapon.TriggerType + +import Dodge.Base +import Data.Maybe import Dodge.Creature.Action -import Dodge.Item.Equipment.Booster +import Dodge.Data import Dodge.Default.Creature +import Dodge.Item.Weapon.TriggerType +import Geometry +import qualified IntMapHelp as IM import LensHelp useL :: Luse -> Item -> Creature -> World -> World @@ -17,25 +21,97 @@ useL lu = case lu of useRewindGun :: Item -> Creature -> World -> World useRewindGun _ _ w = case _rewindWorlds (_cWorld w) of - [w'] -> rewindusing w' [w'] - (w':ws) -> rewindusing w' ws - _ -> w + [w'] -> rewindusing w' [w'] + (w' : ws) -> rewindusing w' ws + _ -> w where rewindusing :: CWorld -> [CWorld] -> World - rewindusing w' ws = w - & cWorld . maybeWorld .~ Just' ( w' - & rewindWorlds .~ ws - ) + rewindusing w' ws = + w + & cWorld . maybeWorld + .~ Just' + ( w' + & rewindWorlds .~ ws + ) -- be careful changing this around; potential problems include updating the -- creature but using the old crInvSel value -- 22.05.23 this has been changed from using invids to items useShrinkGun :: Item -> Creature -> World -> World -useShrinkGun it cr w = if _atBool $ _itAttachment it - then tryResize 0.5 $ stripNoItems cr . f False UndroppableIdentified . dropExcept cr invid - else tryResize 1 $ f True Uncursed . setMinInvSize defaultInvSize cr +useShrinkGun it cr w = + if _atBool $ _itAttachment it + then tryResize 0.5 $ stripNoItems cr . f False UndroppableIdentified . dropExcept cr invid + else tryResize 1 $ f True Uncursed . setMinInvSize defaultInvSize cr where invid = _ipInvID $ _itPos it tryResize x g = maybe w g $ sizeSelf x cr w - f isInUse cstatus = cWorld . creatures . ix (_crID cr) . crInv . ix invid %~ - ( (itAttachment . atBool .~ isInUse) . (itCurseStatus .~ cstatus) ) + f isInUse cstatus = + cWorld . creatures . ix (_crID cr) . crInv . ix invid + %~ ((itAttachment . atBool .~ isInUse) . (itCurseStatus .~ cstatus)) + +boostSelfL :: + -- | boost amount + Float -> + Item -> + Creature -> + World -> + World +boostSelfL x itm cr w = case boostPoint x cr w of + Left p -> crEff p (itUse . leftConsumption . arLoaded .~ 0) + Right p -> crEff p (itUse . leftConsumption . arLoaded -~ 1) + where + invid = _ipInvID $ _itPos itm + cid = _crID cr + cpos = _crPos cr + r = _crRad cr + pid = + fromMaybe + (IM.newKey $ _props (_cWorld w)) + (cr ^? crInv . ix invid . itAttachment . atInt) + crEff p ammoEff = + addBoostShockwave pid p (r *.* normalizeV (p -.- cpos)) w + & cWorld . creatures . ix cid + %~ (crPos .~ p) + . ( crInv . ix invid + %~ ammoEff + . (itEffect . ieCounter .~ 1) + . (itAttachment .~ AttachInt pid) + ) + +-- | Move a creature towards the mouse position, with shockwave +boostPoint :: + -- | boost amount + Float -> + Creature -> + World -> + Either Point2 Point2 +boostPoint x cr w = case mayp2 of + Nothing -> Right p1 + Just p2 -> Left $ mvPointTowardAtSpeed r cpos $ fst p2 + where + cpos = _crPos cr + r = 1.5 * _crRad cr + p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos w -.- cpos) + mayp2 = bouncePoint (const True) 1 cpos p1 w + +addBoostShockwave :: + Int -> + Point2 -> + Point2 -> + World -> + World +addBoostShockwave pjid p v w = + w & cWorld . linearShockwaves + %~ IM.insertWith f pjid thePJ + where + thePJ = + LinearShockwave + { _lwPos = p + , _lwID = pjid + , _lwPoints = [(p, v)] + , _lwTimer = maxT + } + f newVal oldVal = newVal & lwPoints %~ (++ _lwPoints oldVal) + +maxT :: Int +maxT = 20 diff --git a/src/Dodge/Machine/Update.hs b/src/Dodge/Machine/Update.hs index 7d5c5c70a..25c564a7f 100644 --- a/src/Dodge/Machine/Update.hs +++ b/src/Dodge/Machine/Update.hs @@ -1,30 +1,31 @@ module Dodge.Machine.Update where -import Dodge.Data -import Dodge.Machine.Destroy -import Dodge.SoundLogic -import Dodge.Base.You -import Dodge.Base.Collide -import Dodge.Wall.Delete -import Dodge.WorldEvent.Explosion -import Dodge.FloorItem -import Dodge.Item.Weapon.BatteryGuns -import Dodge.Default -import Dodge.Movement.Turn -import Geometry -import LensHelp -import qualified IntMapHelp as IM import Data.List (partition) import Data.Maybe +import Dodge.Base.Collide +import Dodge.Base.You +import Dodge.Data +import Dodge.Default +import Dodge.FloorItem +import Dodge.Item.Weapon.BatteryGuns +import Dodge.Machine.Destroy +import Dodge.Movement.Turn +import Dodge.SoundLogic +import Dodge.Wall.Delete +import Dodge.WorldEvent.Explosion +import Geometry +import qualified IntMapHelp as IM +import LensHelp updateMachine :: Machine -> World -> World updateMachine mc | _mcHP mc < 1 = destroyMachine mc - | otherwise = mcApplyDamage (_mcDamage mc) mc - . mcPlaySound mc - . mcSensorTriggerUpdate mc - . mcTurretUpdate mc - . mcSensorUpdate mc + | otherwise = + mcApplyDamage (_mcDamage mc) mc + . mcPlaySound mc + . mcSensorTriggerUpdate mc + . mcTurretUpdate mc + . mcSensorUpdate mc mcTurretUpdate :: Machine -> World -> World mcTurretUpdate mc = case _mcType mc of @@ -33,50 +34,57 @@ mcTurretUpdate mc = case _mcType mc of -- this needs a major cleanup updateTurret :: Float -> Machine -> World -> World -updateTurret rotSpeed mc w - | _mcHP mc < 1 = w & cWorld . machines %~ IM.delete mcid - & deleteWallIDs (_mcWallIDs mc) - & makeExplosionAt mcpos - & copyItemToFloor mcpos lasGun - & deleteHomonculus - | otherwise = w - & initHomonculus - & dodamage - & maybeFire - & elecDamBranch +updateTurret rotSpeed mc w + | _mcHP mc < 1 = + w & cWorld . machines %~ IM.delete mcid + & deleteWallIDs (_mcWallIDs mc) + & makeExplosionAt mcpos + & copyItemToFloor mcpos lasGun + & deleteHomonculus + | otherwise = + w + & initHomonculus + & dodamage + & maybeFire + & elecDamBranch where deleteHomonculus = case _tuMCrID (_mcType mc) of Nothing -> id Just cid -> cWorld . creatures . at cid .~ Nothing initHomonculus w' = case w' ^? cWorld . machines . ix mcid . mcType . tuMCrID . _Just of - Nothing -> w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid - & cWorld . creatures . at cid ?~ thecreature + Nothing -> + w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid + & cWorld . creatures . at cid ?~ thecreature where cid = IM.newKey (_creatures (_cWorld w')) - thecreature = defaultCreature - & crID .~ cid - & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10 - & itConsumption . laLoaded .~ 1 - ) - & crPos .~ mcpos - & crOldPos .~ mcpos - & crRad .~ 1 - & crDir .~ mcdir - & crStance . posture .~ Aiming - & crMaterial .~ Crystal - Just cid -> w' - & cWorld . creatures . ix cid . crPos .~ mcpos - & cWorld . creatures . ix cid . crDir .~ mcdir - dodamage = cWorld . machines . ix mcid %~ - ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect]) - . (mcHP -~ dam) - ) + thecreature = + defaultCreature + & crID .~ cid + & crInv . at 0 + ?~ ( _tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10 + & itUse . heldConsumption . laLoaded .~ 1 + ) + & crPos .~ mcpos + & crOldPos .~ mcpos + & crRad .~ 1 + & crDir .~ mcdir + & crStance . posture .~ Aiming + & crMaterial .~ Crystal + Just cid -> + w' + & cWorld . creatures . ix cid . crPos .~ mcpos + & cWorld . creatures . ix cid . crDir .~ mcdir + dodamage = + cWorld . machines . ix mcid + %~ ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect]) + . (mcHP -~ dam) + ) elecDamBranch | elecDam < 10 = updateFiringStatus . doTurn | otherwise = id maybeFire - | _tuFireTime (_mcType mc) > 0 - = fromMaybe id $ do + | _tuFireTime (_mcType mc) > 0 = + fromMaybe id $ do cid <- _tuMCrID (_mcType mc) return $ cWorld . creatures . ix cid . crActionPlan . apImpulse .~ [UseItem] | otherwise = id @@ -88,13 +96,13 @@ updateTurret rotSpeed mc w (elecDams, dams) = partition isElectrical $ _mcDamage mc dam = sum $ map _dmAmount dams elecDam = sum $ map _dmAmount elecDams - doTurn + doTurn | seesYou = cWorld . machines . ix mcid . mcDir %~ turnTo rotSpeed mcpos ypos | otherwise = id closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1 - updateFiringStatus + updateFiringStatus | closeFireAngle = cWorld . machines . ix mcid . mcType . tuFireTime .~ 20 - | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1) + | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1) mcSensorTriggerUpdate :: Machine -> World -> World mcSensorTriggerUpdate mc = fromMaybe id $ do @@ -107,59 +115,64 @@ mcTriggerVal mc = case mc ^. mcSensor of NoSensor -> Nothing s@ProximitySensor{} -> s ^? sensToggle s@DamageSensor{} -> Just $ _sensAmount s > 900 - + mcPlaySound :: Machine -> World -> World mcPlaySound mc w = case _mcCloseSound mc of - Just sid | d < 100 - -> soundContinueVol (1-0.01*d) (MachineSound mid) (_mcPos mc) sid (Just 2) w - _ -> w + Just sid + | d < 100 -> + soundContinueVol (1 -0.01 * d) (MachineSound mid) (_mcPos mc) sid (Just 2) w + _ -> w where d = max 0 (dist (_crPos $ you w) (_mcPos mc) - 100) mid = _mcID mc mcApplyDamage :: [Damage] -> Machine -> World -> World mcApplyDamage ds mc = case _mcSensor mc of - NoSensor -> cWorld . machines . ix (_mcID mc) %~ - ( (mcDamage .~ []) . (mcHP -~ sum (map _dmAmount ds)) ) + NoSensor -> + cWorld . machines . ix (_mcID mc) + %~ ((mcDamage .~ []) . (mcHP -~ sum (map _dmAmount ds))) _ -> id mcSensorUpdate :: Machine -> World -> World mcSensorUpdate mc w = case _mcSensor mc of NoSensor -> w - s@DamageSensor{} -> senseDamage (_sensType s) mc w + s@DamageSensor{} -> senseDamage (_sensType s) mc w ProximitySensor{} -> mcProximitySensorUpdate mc w mcProximitySensorUpdate :: Machine -> World -> World -mcProximitySensorUpdate mc w = case - ( _proxStatus sens - , _sensToggle sens - , mcProxTest mc w - , dist (_crPos ycr) (_mcPos mc) < _proxDist sens) of - (_,True,_,_) -> w - (_,False,True,True) -> w +mcProximitySensorUpdate mc w = case ( _proxStatus sens + , _sensToggle sens + , mcProxTest mc w + , dist (_crPos ycr) (_mcPos mc) < _proxDist sens + ) of + (_, True, _, _) -> w + (_, False, True, True) -> + w & cWorld . machines . ix (_mcID mc) . mcSensor . sensToggle .~ True & playsound dedaS & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose - (NotClose,_,False,True) -> w & playsound dedumS + (NotClose, _, False, True) -> + w & playsound dedumS & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose - (_,_,_,False) -> w & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ NotClose + (_, _, _, False) -> w & cWorld . machines . ix (_mcID mc) . mcSensor . proxStatus .~ NotClose _ -> w - where + where playsound sid = soundContinue (MachineAltSound (_mcID mc)) (_mcPos mc) sid Nothing ycr = you w sens = _mcSensor mc mcProxTest :: Machine -> World -> Bool mcProxTest mc w = case mc ^? mcSensor . proxRequirement of - Just (RequireHealth x) -> _crHP cr >= x - Just (RequireEquipment ct) -> any (\itm -> _iyBase (_itType itm) == ct) (_crInv cr) + Just (RequireHealth x) -> _crHP cr >= x + Just (RequireEquipment ct) -> any (\itm -> _iyBase (_itType itm) == ct) (_crInv cr) _ -> False where cr = you w - + senseDamage :: DamageType -> Machine -> World -> World -senseDamage dt mc = (cWorld . machines . ix mcid %~ upmc) - . updatels +senseDamage dt mc = + (cWorld . machines . ix mcid %~ upmc) + . updatels where upmc = mcSensor . sensAmount %~ min 1000 . max 0 . (+ (newsense - 5)) mcid = _mcID mc @@ -173,4 +186,3 @@ damageUsing :: DamageType -> Damage -> Either Int Int damageUsing dt dm | _dmType dm == dt = Left $ _dmAmount dm | otherwise = Right 0 - diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 61b49362d..a3b549d4d 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -1,66 +1,72 @@ -module Dodge.Menu - ( scodeToChar - , pauseMenu - , gameOverMenu - ) where -import Dodge.Config.Data -import LensHelp -import Dodge.Menu.OptionType -import Dodge.StartNewGame -import Dodge.Menu.PushPop +module Dodge.Menu ( + scodeToChar, + pauseMenu, + gameOverMenu, +) where + +import Dodge.Config.Update import Dodge.Data +import Dodge.Menu.OptionType +import Dodge.Menu.PushPop import Dodge.PreloadData import Dodge.Save -import Dodge.Config.Update -import Padding ---import SDL.Internal.Numbered ---import Preload.Update import Dodge.SoundLogic +import Dodge.StartNewGame +import LensHelp +import Padding --import Dodge.LevelGen -import Text.Read import SDL import System.Clipboard +import Text.Read + --import Control.Lens --import System.Random slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer -slTitleOptionsEff title ops eff = OptionScreen - { _scTitle = const title - , _scOptions = ops - , _scDefaultEff = eff - , _scOptionFlag = NormalOptions - , _scOptionsOffset = 0 - } +slTitleOptionsEff title ops eff = + OptionScreen + { _scTitle = const title + , _scOptions = ops + , _scDefaultEff = eff + , _scOptionFlag = NormalOptions + , _scOptionsOffset = 0 + } + pauseMenu :: ScreenLayer pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause) + pauseMenuOptions :: [MenuOption] -pauseMenuOptions = basicKeyOptions - [ Toggle (return . Just . startNewGame) (opText "NEW LEVEL") - , Toggle (return . Just . loadSaveSlot LevelStartSlot) (opText "RESTART") - , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "START FROM SEED") - , Toggle (pushScreen optionMenu ) (opText "OPTIONS") - , Toggle (pushScreen displayControls) (opText "CONTROLS") - ] - ++ - [ InvisibleToggle ScancodeEscape (return . const Nothing) - ] +pauseMenuOptions = + basicKeyOptions + [ Toggle (return . Just . startNewGame) (opText "NEW LEVEL") + , Toggle (return . Just . loadSaveSlot LevelStartSlot) (opText "RESTART") + , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "START FROM SEED") + , Toggle (pushScreen optionMenu) (opText "OPTIONS") + , Toggle (pushScreen displayControls) (opText "CONTROLS") + ] + ++ [ InvisibleToggle ScancodeEscape (return . const Nothing) + ] where opText = const . Left + seedStartMenu :: String -> ScreenLayer seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen + seedStartOptions :: [MenuOption] seedStartOptions = [ Toggle trySeedFromClipboard (const $ Left "PASTE NUMBER FROM CLIPBOARD") ScancodeA --- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER") + -- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER") ] trySeedFromClipboard :: Universe -> IO (Maybe Universe) trySeedFromClipboard u = do mcstr <- getClipboardString case mcstr >>= readMaybe of - Nothing -> pushScreen (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER") - (u & menuLayers %~ tail) + Nothing -> + pushScreen + (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER") + (u & menuLayers %~ tail) Just i -> return . Just $ startSeedGame i u slTitleOptions :: String -> [MenuOption] -> ScreenLayer @@ -70,70 +76,84 @@ optionMenu :: ScreenLayer optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen optionsOptions :: [MenuOption] -optionsOptions = basicKeyOptions - [ makeSubmenuOption soundMenu $ Left "VOLUME" - , makeSubmenuOption graphicsMenu $ Left "GRAPHICS" - , makeSubmenuOption gameplayMenu $ Left "GAMEPLAY" - , makeSubmenuOption debugMenu $ Left "DEBUG OPTIONS" - ] +optionsOptions = + basicKeyOptions + [ makeSubmenuOption soundMenu $ Left "VOLUME" + , makeSubmenuOption graphicsMenu $ Left "GRAPHICS" + , makeSubmenuOption gameplayMenu $ Left "GAMEPLAY" + , makeSubmenuOption debugMenu $ Left "DEBUG OPTIONS" + ] + debugMenu :: ScreenLayer -debugMenu = slTitleOptions - "OPTIONS:GAMEPLAY" - debugMenuOptions +debugMenu = + slTitleOptions + "OPTIONS:GAMEPLAY" + debugMenuOptions + debugMenuOptions :: [MenuOption] -debugMenuOptions = zipWith ($) - (map f [minBound..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return] ) - $ map Scancode [4..] +debugMenuOptions = + zipWith + ($) + (map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return]) + $ map Scancode [4 ..] where f :: DebugBool -> Scancode -> MenuOption - f bd = Toggle (return . Just . (uvConfig . debug_booleans . at bd %~ toggleJust)) - (Right . g bd . (^? uvConfig . debug_booleans . ix bd)) + f bd = + Toggle + (return . Just . (uvConfig . debug_booleans . at bd %~ toggleJust)) + (Right . g bd . (^? uvConfig . debug_booleans . ix bd)) g bd Nothing = (show bd, "False") - g bd _ = (show bd, "True") + g bd _ = (show bd, "True") + -- zipWith ($) --- [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" --- , makeBoolOption debug_noclip "NOCLIP" --- , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" --- , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" --- , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" --- , makeBoolOption debug_pathing "SHOW PATHING" --- , makeBoolOption debug_show_sound "SHOW VISUAL SOUNDS" --- , makeBoolOption debug_mouse_position "SHOW MOUSE POSITION" +-- [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" +-- , makeBoolOption debug_noclip "NOCLIP" +-- , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" +-- , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" +-- , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" +-- , makeBoolOption debug_pathing "SHOW PATHING" +-- , makeBoolOption debug_show_sound "SHOW VISUAL SOUNDS" +-- , makeBoolOption debug_mouse_position "SHOW MOUSE POSITION" -- , makeBoolOption debug_walls "SHOW WALL INFO" -- , makeBoolOption debug_remove_LOS "REMOVE LOS" -- , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS" -- ] -- $ map Scancode [4 ..] gameplayMenu :: ScreenLayer -gameplayMenu = slTitleOptions - "OPTIONS:GAMEPLAY" - gameplayMenuOptions +gameplayMenu = + slTitleOptions + "OPTIONS:GAMEPLAY" + gameplayMenuOptions gameplayMenuOptions :: [MenuOption] -gameplayMenuOptions = basicKeyOptions - [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL" - ] +gameplayMenuOptions = + basicKeyOptions + [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL" + ] + basicKeyOptions :: [Scancode -> c] -> [c] -basicKeyOptions xs = zipWith ($) xs $ map Scancode [4 .. ] +basicKeyOptions xs = zipWith ($) xs $ map Scancode [4 ..] soundMenu :: ScreenLayer -soundMenu = slTitleOptions - "OPTIONS:VOLUME" - soundMenuOptions +soundMenu = + slTitleOptions + "OPTIONS:VOLUME" + soundMenuOptions soundMenuOptions :: [MenuOption] soundMenuOptions = - [ theoption ScancodeY volume_master ScancodeU "MASTER VOLUME" _volume_master - , theoption ScancodeH volume_sound ScancodeJ "EFFECTS VOLUME" _volume_sound - , theoption ScancodeN volume_music ScancodeM "MUSIC VOLUME" _volume_music + [ theoption ScancodeY volume_master ScancodeU "MASTER VOLUME" _volume_master + , theoption ScancodeH volume_sound ScancodeJ "EFFECTS VOLUME" _volume_sound + , theoption ScancodeN volume_music ScancodeM "MUSIC VOLUME" _volume_music ] where - theoption scod1 stype scod2 str voltype = Toggle2 - scod1 - (change dec stype) - scod2 - (change inc stype) - (\w -> Right (str , leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w)::Int))) + theoption scod1 stype scod2 str voltype = + Toggle2 + scod1 + (change dec stype) + scod2 + (change inc stype) + (\w -> Right (str, leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int))) change g vt uv = sw uv >> return (Just $ uv & uvConfig . vt %~ g) dec x = max 0 (x - 0.1) inc x = min 1 (x + 0.1) @@ -146,27 +166,28 @@ graphicsMenu :: ScreenLayer graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions graphicsMenuOptions :: [MenuOption] -graphicsMenuOptions = basicKeyOptions - [ makeEnumOption graphics_resolution_factor "RESOLUTION" updateFramebufferSize - , makeBoolOption graphics_wall_textured "WALL TEXTURES" - , makeBoolOption graphics_object_shadows "OBJECT SHADOWS" - , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS" - ] +graphicsMenuOptions = + basicKeyOptions + [ makeEnumOption graphics_resolution_factor "RESOLUTION" updateFramebufferSize + , makeBoolOption graphics_wall_textured "WALL TEXTURES" + , makeBoolOption graphics_object_shadows "OBJECT SHADOWS" + , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS" + ] gameOverMenu :: ScreenLayer -gameOverMenu = OptionScreen - { _scTitle = const "GAME OVER" - , _scOptions = pauseMenuOptions - , _scDefaultEff = return . Just - , _scOptionFlag = GameOverOptions - , _scOptionsOffset = 0 - } +gameOverMenu = + OptionScreen + { _scTitle = const "GAME OVER" + , _scOptions = pauseMenuOptions + , _scDefaultEff = return . Just + , _scOptionFlag = GameOverOptions + , _scOptionsOffset = 0 + } -- | hacky - no longer used scodeToChar :: Scancode -> Char scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode - --charToScode :: Char -> Scancode --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum @@ -176,20 +197,20 @@ unpause w = Just . resumeSound $ w & menuLayers .~ [] displayControls :: ScreenLayer displayControls = ColumnsScreen (const "CONTROLS") listControls -listControls :: [(String,String)] +listControls :: [(String, String)] listControls = - [("wasd", "MOVEMENT") - ,("[rmb]", "AIM") - ,("[rmb+lmb]", "SHOOT/USE/EQUIP SELECTED") - ,("[lmb]", "USE EQUIPPED") - ,("[wheelscroll]" , "SELECT ITEM" ) - ,("[space]" , "PICKUP ITEM" ) - ,("m" , "DISPLAY MAP" ) - ,("f" , "DROP ITEM" ) - ,("c" , "COMBINE ITEMS" ) - ,("x" , "TWEAK ITEMS" ) - ,("c[esc]" , "PAUSE" ) - ,("qe" , "ROTATE CAMERA") - ,("F5" , "QUICKSAVE") - ,("F9" , "QUICKLOAD") + [ ("wasd", "MOVEMENT") + , ("[rmb]", "AIM") + , ("[rmb+lmb]", "SHOOT/USE/EQUIP SELECTED") + , ("[lmb]", "USE EQUIPPED") + , ("[wheelscroll]", "SELECT ITEM") + , ("[space]", "PICKUP ITEM") + , ("m", "DISPLAY MAP") + , ("f", "DROP ITEM") + , ("c", "COMBINE ITEMS") + , ("x", "TWEAK ITEMS") + , ("c[esc]", "PAUSE") + , ("qe", "ROTATE CAMERA") + , ("F5", "QUICKSAVE") + , ("F9", "QUICKLOAD") ] diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index de5fa620b..3225a672e 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/src/Dodge/Placement/Instance/Turret.hs @@ -61,7 +61,7 @@ updateTurret rotSpeed mc w thecreature = defaultCreature & crID .~ cid & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10 - & itConsumption . laLoaded .~ 1 + & itUse . heldConsumption . laLoaded .~ 1 ) & crPos .~ mcpos & crOldPos .~ mcpos diff --git a/src/Dodge/Projectile/Create.hs b/src/Dodge/Projectile/Create.hs index 91e453deb..746a44ba4 100644 --- a/src/Dodge/Projectile/Create.hs +++ b/src/Dodge/Projectile/Create.hs @@ -41,7 +41,7 @@ makeShell it cr theupdate w = w & cWorld . projectiles %~ IM.insert i Shell i = IM.newKey $ _props (_cWorld w) dir = _crDir cr pos = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) 0) - am = _itConsumption it + am = _heldConsumption $ _itUse it --fireShell :: Item -> Creature -> World -> World --fireShell it cr = makeShell it cr $ \pj -> pjEffAtTime 35 (trySpinByCID (_crID cr) spinamount) pj diff --git a/src/Dodge/Projectile/Update.hs b/src/Dodge/Projectile/Update.hs index 709d55e2e..e0e9b7a63 100644 --- a/src/Dodge/Projectile/Update.hs +++ b/src/Dodge/Projectile/Update.hs @@ -1,32 +1,33 @@ {-# OPTIONS_GHC -Wno-unused-imports #-} + module Dodge.Projectile.Update where -import Dodge.Item.Weapon.Launcher + +--import qualified Data.Set as S + +import Control.Lens +import qualified Data.Map.Strict as M +import Data.Maybe +import Dodge.Base import Dodge.Data -import Dodge.Payload -import Dodge.Reloading.Action -import Dodge.EnergyBall import Dodge.Default.Weapon +import Dodge.EnergyBall import Dodge.Item.Location -import Dodge.SoundLogic.LoadSound -import Dodge.Item.Weapon.Shell +import Dodge.Item.Weapon.Launcher import Dodge.Item.Weapon.Remote +import Dodge.Item.Weapon.Shell import Dodge.Item.Weapon.TriggerType import Dodge.Movement.Turn -import Dodge.Base -import Dodge.Zone +import Dodge.Payload +import Dodge.Reloading.Action import Dodge.SoundLogic +import Dodge.SoundLogic.LoadSound import Dodge.WorldEvent.Cloud -import RandomHelp +import Dodge.Zone import Geometry import qualified IntMapHelp as IM - -import qualified Streaming.Prelude as S ---import qualified Data.Set as S -import qualified Data.Map.Strict as M +import RandomHelp import qualified SDL -import Data.Maybe -import Control.Lens - +import qualified Streaming.Prelude as S updateProjectile :: Proj -> World -> World updateProjectile pj = case pj of @@ -35,65 +36,72 @@ updateProjectile pj = case pj of updateRemoteShell :: Proj -> World -> World updateRemoteShell pj w - | time > 340 = if circOnSomeWall oldPos 4 w - then doExplode - else w + | time > 340 = + if circOnSomeWall oldPos 4 w + then doExplode + else w | anythingHitCirc 2 oldPos newPos w = doExplode | time > 0 = w | otherwise = doExplode - where + where time = _prjTimer pj - doExplode = w - & usePayload (_prjPayload pj) oldPos - & stopSoundFrom (ShellSound i) - & cWorld . projectiles %~ IM.delete i + doExplode = + w + & usePayload (_prjPayload pj) oldPos + & stopSoundFrom (ShellSound i) + & cWorld . projectiles %~ IM.delete i i = _prjID pj - oldPos = _prjPos pj - vel = _prjVel pj - newPos = oldPos +.+ vel + oldPos = _prjPos pj + vel = _prjVel pj + newPos = oldPos +.+ vel -explodeRemoteRocket' - :: Maybe Int -- ^ Item id - -> Proj - -> World - -> World -explodeRemoteRocket' mitid thepj w = w - & cWorld . projectiles . ix pjid . prjDraw .~ DrawBlankProjectile - & usePayload (_prjPayload thepj) (_prjPos thepj) - & updateitem - where +explodeRemoteRocket' :: + -- | Item id + Maybe Int -> + Proj -> + World -> + World +explodeRemoteRocket' mitid thepj w = + w + & cWorld . projectiles . ix pjid . prjDraw .~ DrawBlankProjectile + & usePayload (_prjPayload thepj) (_prjPos thepj) + & updateitem + where updateitem = fromMaybe (cWorld . projectiles . at pjid .~ Nothing) $ do itid <- mitid itpos <- w ^? cWorld . itemPositions . ix itid - return $ (pointToItem itpos . itUse . rUse .~ HeldDoNothing) - . (cWorld . projectiles . ix pjid . prjUpdates .~ [PJRetireRemote itid 30 pjid]) + return $ + (pointerToItem itpos . itUse . rUse .~ HeldDoNothing) + . (cWorld . projectiles . ix pjid . prjUpdates .~ [PJRetireRemote itid 30 pjid]) pjid = _prjID thepj updateShell :: Proj -> World -> World updateShell pj w - | time > 340 = if circOnSomeWall oldPos 4 w - then doExplode - else w + | time > 340 = + if circOnSomeWall oldPos 4 w + then doExplode + else w | anythingHitCirc 2 oldPos newPos w = doExplode | time > 0 = w | otherwise = doExplode - where + where time = _prjTimer pj - doExplode = w - & usePayload (_prjPayload pj) oldPos - & stopSoundFrom (ShellSound i) - & cWorld . projectiles %~ IM.delete i + doExplode = + w + & usePayload (_prjPayload pj) oldPos + & stopSoundFrom (ShellSound i) + & cWorld . projectiles %~ IM.delete i i = _prjID pj - oldPos = _prjPos pj - vel = _prjVel pj - newPos = oldPos +.+ vel + oldPos = _prjPos pj + vel = _prjVel pj + newPos = oldPos +.+ vel upsProjectile :: Proj -> World -> World upsProjectile pj w' = foldr (`upProjectile` pj) w' (_prjUpdates pj) upProjectile :: ProjectileUpdate -> Proj -> World -> World upProjectile pu pj = case pu of - PJThrust st et + PJThrust st et | act st et -> doThrust' pj | otherwise -> id PJSpin t cid spinamount @@ -115,52 +123,56 @@ upProjectile pu pj = case pu of ain t = time == t retireRemoteProj'' :: Int -> Int -> World -> World -retireRemoteProj'' itid pjid w = w - & pointToItem (_itemPositions (_cWorld w) IM.! itid) %~ - ( (itScope . scopePos .~ V2 0 0) - . (itUse . rUse .~ HeldFireRemoteShell) - ) - & cWorld . props %~ IM.delete pjid +retireRemoteProj'' itid pjid w = + w + & pointerToItem (_itemPositions (_cWorld w) IM.! itid) + %~ ( (itScope . scopePos .~ V2 0 0) + . (itUse . rUse .~ HeldFireRemoteShell) + ) + & cWorld . props %~ IM.delete pjid setRemoteDir :: Int -> Int -> Proj -> World -> World setRemoteDir cid itid pj w = w & cWorld . projectiles . ix (_prjID pj) . prjDir .~ newdir where --i = _prjID pj - newdir + newdir | SDL.ButtonRight `M.member` _mouseButtons w - && w ^? cWorld . creatures . ix cid . crInvSel . iselPos - == w ^? cWorld . itemPositions . ix itid . ipInvID - = _cameraRot (_cWorld w) + argV (_mousePos w) + && w ^? cWorld . creatures . ix cid . crInvSel . iselPos + == w ^? cWorld . itemPositions . ix itid . ipInvID = + _cameraRot (_cWorld w) + argV (_mousePos w) | otherwise = _prjDir pj doThrust' :: Proj -> World -> World -doThrust' pj w = w - & randGen .~ g - & cWorld . projectiles . ix i . prjVel %~ (\v -> accel +.+ frict *.* v) - & soundContinue (ShellSound i) newPos missileLaunchS (Just 1) - & makeFlamelet (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) 3 10 - & shellTrailCloud (addZ 20 (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos))) +doThrust' pj w = + w + & randGen .~ g + & cWorld . projectiles . ix i . prjVel %~ (\v -> accel +.+ frict *.* v) + & soundContinue (ShellSound i) newPos missileLaunchS (Just 1) + & makeFlamelet (oldPos -.- vel) 0 (vel +.+ rotateV (pi + sparkD) accel) 3 10 + & shellTrailCloud (addZ 20 (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos))) where - accel = _prjAcc pj - i = _prjID pj - oldPos = _prjPos pj - vel = _prjVel pj - newPos = oldPos +.+ vel - (frict,g) = randomR (0.6,0.9) $ _randGen w - (sparkD,_) = randomR (-0.2,0.2) $ _randGen w + accel = _prjAcc pj + i = _prjID pj + oldPos = _prjPos pj + vel = _prjVel pj + newPos = oldPos +.+ vel + (frict, g) = randomR (0.6, 0.9) $ _randGen w + (sparkD, _) = randomR (-0.2, 0.2) $ _randGen w r1 = randInCirc 10 & evalState $ _randGen w -trySpinByCID' - :: Int -- ^ creature id - -> Int -- ^ Spin amount - -> Proj - -> World - -> World +trySpinByCID' :: + -- | creature id + Int -> + -- | Spin amount + Int -> + Proj -> + World -> + World trySpinByCID' cid i pj w = w & cWorld . projectiles . ix pjid . prjSpin .~ newSpin where pjid = _prjID pj - dir = argV $ _prjVel pj - newSpin = case w ^? cWorld . creatures . ix cid of + dir = argV $ _prjVel pj + newSpin = case w ^? cWorld . creatures . ix cid of Just cr -> negate $ min 0.2 $ max (-0.2) $ normalizeAnglePi (dir - _crDir cr) / spinFactor _ -> 0 spinFactor = 5 * (6 - fromIntegral i) @@ -170,9 +182,14 @@ pjTrack' itid pj w = rotateToTarget pj w where rotateToTarget _ = fromMaybe id $ do tpos <- w ^? itPoint . itTargeting . tgPos . _Just - return $ cWorld . projectiles . ix (_prjID pj) . prjSpin .~ turnToAmount 0.15 (_prjPos pj) tpos - (argV $ _prjAcc pj) - itPoint = pointToItem $ _itemPositions (_cWorld w) IM.! itid + return $ + cWorld . projectiles . ix (_prjID pj) . prjSpin + .~ turnToAmount + 0.15 + (_prjPos pj) + tpos + (argV $ _prjAcc pj) + itPoint = pointerToItem $ _itemPositions (_cWorld w) IM.! itid reduceSpinBy' :: Float -> Proj -> World -> World -reduceSpinBy' x pj = cWorld . projectiles . ix (_prjID pj) . prjSpin *~ x +reduceSpinBy' x pj = cWorld . projectiles . ix (_prjID pj) . prjSpin *~ x diff --git a/src/Dodge/Reloading.hs b/src/Dodge/Reloading.hs index 712f77b3f..f2f1db859 100644 --- a/src/Dodge/Reloading.hs +++ b/src/Dodge/Reloading.hs @@ -13,7 +13,7 @@ import Control.Lens crCancelReloading :: Creature -> Creature crCancelReloading cr = cr - & crInv . ix (crSel cr) . itConsumption . laProgress %~ const Nothing + & crInv . ix (crSel cr) . itUse . heldConsumption . laProgress %~ const Nothing & crInvSel . iselAction .~ NoInvSelAction stepReloading :: Creature -> Creature @@ -24,13 +24,13 @@ stepReloading cr = case cr ^?! crInvSel . iselAction of & crInvSel . iselAction . actionHammer . hammerPosition %~ moveHammerUp | otherwise -> cr & crInvSel . iselAction . actionHammer . hammerPosition %~ moveHammerUp - & crInv . ix (crSel cr) . itConsumption %~ doLoadAction la - & crInv . ix (crSel cr) . itConsumption %~ rotateActionProgress + & crInv . ix (crSel cr) . itUse . heldConsumption %~ doLoadAction la + & crInv . ix (crSel cr) . itUse . heldConsumption %~ rotateActionProgress & tryNextLoadAction _ -> cr tryNextLoadAction :: Creature -> Creature -tryNextLoadAction cr = case cr ^? crInv . ix (crSel cr) . itConsumption . laProgress . _Just . ix 0 of +tryNextLoadAction cr = case cr ^? crInv . ix (crSel cr) . itUse . heldConsumption . laProgress . _Just . ix 0 of Nothing -> cr & crInvSel . iselAction .~ NoInvSelAction Just la -> cr & crInvSel . iselAction . actionProgress .~ _actionTime la & crInvSel . iselAction . reloadAction .~ la @@ -52,22 +52,22 @@ tryStartLoading cr = case ic ^? laProgress . _Just . ix 0 of Just [] -> error ("item has empty load cycle" ++ show (cr ^?! crInv . ix (crSel cr) . itType)) Just _ | _laLoaded ic >= _laMax ic -> cr Just (la:las) -> cr & startLoadAction la - & crInv . ix (crSel cr) . itConsumption . laProgress ?~ (la:las) + & crInv . ix (crSel cr) . itUse . heldConsumption . laProgress ?~ (la:las) where - ic = cr ^?! crInv . ix (crSel cr) . itConsumption + ic = cr ^?! crInv . ix (crSel cr) . itUse . heldConsumption startLoadAction :: LoadAction -> Creature -> Creature startLoadAction la cr = cr & crInvSel . iselAction .~ ReloadAction (_actionTime la) la NoHammer -rotateActionProgress :: ItemConsumption -> ItemConsumption +rotateActionProgress :: HeldConsumption -> HeldConsumption rotateActionProgress ic = case ic ^? laProgress . _Just of Just (_:la:las) -> ic & laProgress . _Just .~ (la:las) _ | _laLoaded ic < _laMax ic -> ic & laProgress ?~ _laCycle ic _ -> ic & laProgress .~ Nothing -doLoadAction :: LoadAction -> ItemConsumption -> ItemConsumption +doLoadAction :: LoadAction -> HeldConsumption -> HeldConsumption doLoadAction la ic = case la of LoadEject {} -> ic & laLoaded .~ 0 & laPrimed .~ False LoadInsert {} -> ic & laLoaded .~ _laMax ic diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 5a5951bd4..c6ee4e8e4 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -80,12 +80,12 @@ subInventoryDisplay subinv cfig w = case subinv of , equipcursor -- the order is important, this should go on top of the other equipcursors , rboptions ] - TweakInventory -> pictures + TweakInventory mtweaki -> pictures --[ mCurs it cfig w [ selcursor' listCursorNESW -- , cursorsZ cfig curpos it , fromMaybe mempty $ do - tweaki <- it ^? _Just . itTweaks . tweakSel + tweaki <- mtweaki -- consider moving this functionality out into a tweaks module tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki return $ lnkMidInvSel cfig w curpos tweaki @@ -234,8 +234,8 @@ lnkMidInvSel cfig w lefti midi = winScale cfig combineCounts :: Configuration -> World -> [Int] -> Picture combineCounts cfig w = winScale cfig . foldMap f . group where - f (i:is) = case yourInv w ^? ix i . itConsumption of - Just ItemItselfConsumable{} -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-': show (length is + 1)) + f (i:is) = case yourInv w ^? ix i . itUse . useAmount of + Just _ -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-': show (length is + 1)) _ -> mempty f _ = mempty diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 4023b0d20..582962bdb 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -27,7 +27,7 @@ import Dodge.Spark.Draw import Dodge.RadarBlip import Dodge.Flare import Dodge.ShortShow -import Dodge.Config.Data +import Dodge.Data.Config import Dodge.Render.InfoBox import Dodge.Debug.Picture import Dodge.Picture.SizeInvariant diff --git a/src/Dodge/Room/Breather.hs b/src/Dodge/Room/Breather.hs index d41182224..fa3c1d4f2 100644 --- a/src/Dodge/Room/Breather.hs +++ b/src/Dodge/Room/Breather.hs @@ -1,42 +1,21 @@ module Dodge.Room.Breather where ---import Dodge.Cleat -import Dodge.Combine.Data -import Dodge.Data ---import Dodge.PlacementSpot ---import Dodge.RoomLink ---import Dodge.Default.Room -import Dodge.Item ---import Dodge.Creature ---import Dodge.Room.Pillar ---import Dodge.Room.Girder ---import Dodge.Room.Modify.Girder ---import Dodge.LevelGen.Data -import RandomHelp -import Dodge.Tree ---import Dodge.Placement.Instance ---import Dodge.LevelGen.Data ---import Dodge.Room.Procedural ---import Dodge.Room.Corridor ---import Dodge.Room.Tanks ---import Dodge.Room.Link ---import Dodge.Room.Door ---import Dodge.Room.Airlock -import Dodge.Room.Containing ---import Geometry ---import MonadHelp ---import LensHelp ---import qualified Data.Set as S +import Dodge.Data +import Dodge.Item +import Dodge.Room.Containing +import Dodge.Tree +import RandomHelp firstBreather :: State StdGen (MetaTree Room String) firstBreather = do - itms <- takeOne - [[itemFromBase $ CRAFT TUBE] - ,[itemFromBase $ CRAFT PIPE] - ,[itemFromBase $ CRAFT HARDWARE] - ,[itemFromBase $ CRAFT CAN] - ,[itemFromBase $ CRAFT TIN] - ,[itemFromBase $ CRAFT PLANK] - ,[itemFromBase $ CRAFT DRUM] - ] + itms <- + takeOne + [ [itemFromBase $ CRAFT TUBE] + , [itemFromBase $ CRAFT PIPE] + , [itemFromBase $ CRAFT HARDWARE] + , [itemFromBase $ CRAFT CAN] + , [itemFromBase $ CRAFT TIN] + , [itemFromBase $ CRAFT PLANK] + , [itemFromBase $ CRAFT DRUM] + ] roomsContaining [] itms diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index 359dad06a..669fcdcaf 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -65,7 +65,7 @@ keyCardRoomRunPast keyid rmid = do ] keyCardAnalyserByDoor :: Int -> Int -> Room -> Room -keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (KEYCARD keyid)) +keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (HELD (KEYCARD keyid))) healthAnalyserByDoor :: Int -> Room -> Room healthAnalyserByDoor = analyserByDoor (RequireHealth 1100) diff --git a/src/Dodge/WindowLayout.hs b/src/Dodge/WindowLayout.hs index 317ea19da..92f340871 100644 --- a/src/Dodge/WindowLayout.hs +++ b/src/Dodge/WindowLayout.hs @@ -1,5 +1,6 @@ module Dodge.WindowLayout where -import Dodge.Config.Data + +import Dodge.Data.Config availableMenuLines :: Configuration -> Int -availableMenuLines = floor . (/50) . subtract 125 . _windowY +availableMenuLines = floor . (/ 50) . subtract 125 . _windowY diff --git a/src/Dodge/Zoning/Base.hs b/src/Dodge/Zoning/Base.hs index 1f80429c0..ba79a5e87 100644 --- a/src/Dodge/Zoning/Base.hs +++ b/src/Dodge/Zoning/Base.hs @@ -1,12 +1,12 @@ module Dodge.Zoning.Base where + +import Control.Lens +import qualified Data.IntSet as IS +import Data.Maybe import Geometry import Geometry.Zone import qualified IntMapHelp as IM -import qualified Data.IntSet as IS -import Control.Lens -import Data.Maybe - zoneOfCirc :: Float -> Point2 -> Float -> [Int2] zoneOfCirc zsize p r = zoneOfRect' zsize (p +.+ V2 r r) (p -.- V2 r r) @@ -18,37 +18,39 @@ zoneOfRect' s sp ep = [V2 x y | x <- makeIntInterval sx ex, y <- makeIntInterval makeIntInterval :: Int -> Int -> [Int] makeIntInterval x y - | x < y = [x..y] - | otherwise = [y..x] + | x < y = [x .. y] + | otherwise = [y .. x] makeInt2Interval :: Int2 -> Int2 -> [Int2] -makeInt2Interval (V2 x1 y1) (V2 x2 y2) - = [V2 x y | x <- makeIntInterval x1 x2, y <- makeIntInterval y1 y2] +makeInt2Interval (V2 x1 y1) (V2 x2 y2) = + [V2 x y | x <- makeIntInterval x1 x2, y <- makeIntInterval y1 y2] zoneOfPoint' :: Float -> Point2 -> Int2 -zoneOfPoint' s = fmap (divTo s) +zoneOfPoint' = fmap . divTo zoneOfSeg' :: Float -> Point2 -> Point2 -> [Int2] +{-# INLINE zoneOfSeg' #-} zoneOfSeg' s sp ep = map (zoneOfPoint' s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep) zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m zoneExtract (V2 x y) = fromMaybe mempty . (^? ix x . ix y) --- + zonesExtract :: Monoid m => IM.IntMap (IM.IntMap m) -> [Int2] -> m -zonesExtract im = foldMap (`zoneExtract` im) +{-# INLINE zonesExtract #-} +zonesExtract = foldMap . flip zoneExtract xIntercepts' :: Float -> Point2 -> Point2 -> [Point2] {-# INLINE xIntercepts' #-} -xIntercepts' s (V2 sx sy) (V2 ex ey) - | xdx == 0 = [] - | xdx > 0 = zipWith V2 [sx',sx'+xdx*50..ex] ([sy',sy'+ydx*50..ey] ++ repeat ey) - | otherwise = zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] ([sy',sy'+ydx*50..ey] ++ repeat ey) +xIntercepts' s (V2 sx sy) (V2 ex ey) + | xdx == 0 = [] + | xdx > 0 = zipWith V2 [sx', sx' + xdx * 50 .. ex] ([sy', sy' + ydx * 50 .. ey] ++ repeat ey) + | otherwise = zipWith V2 [sx' -50, sx' + xdx * 50 -50 .. ex -50] ([sy', sy' + ydx * 50 .. ey] ++ repeat ey) where xdx = signum (ex - sx) ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero - sy' = sy + ydx * abs (sx - sx') - sx' | xdx < 0 = sx - modTo s sx + sx' + | xdx < 0 = sx - modTo s sx | otherwise = s + sx - modTo s sx yIntercepts' :: Float -> Point2 -> Point2 -> [Point2] @@ -62,7 +64,7 @@ zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton y a where f _ = IM.insertWith (<>) y a -deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 -> IM.IntMap (IM.IntMap IS.IntSet) +deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 -> IM.IntMap (IM.IntMap IS.IntSet) deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i zoneOfPoint'' :: Float -> Point2 -> Int2 @@ -70,6 +72,6 @@ zoneOfPoint'' :: Float -> Point2 -> Int2 zoneOfPoint'' s = fmap (divTo s) zonesAroundPoint :: Float -> Point2 -> [Int2] -zonesAroundPoint s p = [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ] +zonesAroundPoint s p = [V2 a b | a <- [x -1 .. x + 1], b <- [y -1 .. y + 1]] where V2 x y = zoneOfPoint' s p diff --git a/src/Dodge/Zoning/Wall.hs b/src/Dodge/Zoning/Wall.hs index a16c40c87..50d9a03cd 100644 --- a/src/Dodge/Zoning/Wall.hs +++ b/src/Dodge/Zoning/Wall.hs @@ -13,6 +13,7 @@ wlIXsNearPoint :: Point2 -> World -> IS.IntSet wlIXsNearPoint p w = zoneExtract (zoneOfPoint' wlZoneSize p) (w ^. cWorld . wlZoning) wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet +{-# INLINE wlIXsNearSeg #-} wlIXsNearSeg sp ep w = zonesExtract (w ^. cWorld . wlZoning) (zoneOfSeg' wlZoneSize sp ep) wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 7445f9eb2..a3f778bf6 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -1,159 +1,191 @@ {-# LANGUAGE BangPatterns #-} -module Geometry.Vector - where + +module Geometry.Vector where + import Geometry.Data -{- | Moves from two to three dimensions, adding zero in z direction. -} + +-- | Moves from two to three dimensions, adding zero in z direction. zeroZ :: Point2 -> Point3 {-# INLINE zeroZ #-} zeroZ (V2 x y) = V3 x y 0 infixl 6 +.+, -.- + infixl 7 *.* -{- | 2D coordinate-wise addition. -} +-- | 2D coordinate-wise addition. (+.+) :: Point2 -> Point2 -> Point2 {-# INLINE (+.+) #-} --(+.+) = -- (+) V2 x1 y1 +.+ V2 x2 y2 = - let - !x = x1 + x2 - !y = y1 + y2 - in V2 x y -{- | 2D coordinate-wise subtraction. -} + let !x = x1 + x2 + !y = y1 + y2 + in V2 x y + +-- | 2D coordinate-wise subtraction. (-.-) :: Point2 -> Point2 -> Point2 {-# INLINE (-.-) #-} --(-.-) = (-) V2 x1 y1 -.- V2 x2 y2 = - let - !x = x1 - x2 - !y = y1 - y2 - in V2 x y -{- | 2D scalar multiplication. -} + let !x = x1 - x2 + !y = y1 - y2 + in V2 x y + +-- | 2D scalar multiplication. (*.*) :: Float -> Point2 -> Point2 {-# INLINE (*.*) #-} a *.* V2 x2 y2 = - let - !x = a * x2 - !y = a * y2 - in V2 x y + let !x = a * x2 + !y = a * y2 + in V2 x y -{- | Normalize a vector to length 1. -} +-- | Normalize a vector to length 1. normalizeV :: Point2 -> Point2 {-# INLINE normalizeV #-} normalizeV p = (1 / magV p) *.* p -{- | Angle between two vectors. Always positive. -} +clipV :: Float -> Point2 -> Point2 +{-# INLINE clipV #-} +clipV x v + | magV v > x = x *.* normalizeV v + | otherwise = v + +-- | Angle between two vectors. Always positive. + -- TODO fix this: it seems to be unstable when the two vectors are very close to -- each other angleVV :: Point2 -> Point2 -> Float {-# INLINE angleVV #-} -angleVV a b +angleVV a b | a == b = 0 | otherwise = let ma = magV a mb = magV b - d = a `dotV` b - in acos $ d / (ma * mb) -{- | Safe version of 'angleVV' that returns 0 if either vector is null. -} + d = a `dotV` b + in acos $ d / (ma * mb) + +-- | Safe version of 'angleVV' that returns 0 if either vector is null. safeAngleVV :: Point2 -> Point2 -> Float {-# INLINE safeAngleVV #-} safeAngleVV a b | a == V2 0 0 || b == V2 0 0 = 0 - | otherwise = angleVV a b -{- | Dot product. -} + | otherwise = angleVV a b + +-- | Dot product. dotV :: Point2 -> Point2 -> Float {-# INLINE dotV #-} -dotV (V2 x y) (V2 z w) = x*z + y*w -{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. -} +dotV (V2 x y) (V2 z w) = x * z + y * w + +-- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. argV :: Point2 -> Float {-# INLINE argV #-} argV (V2 x y) = normalizeAngle $ atan2 y x -{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. - Returns Nothing for a 0 0 vector. -} +{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. + Returns Nothing for a 0 0 vector. +-} safeArgV :: Point2 -> Maybe Float {-# INLINE safeArgV #-} safeArgV (V2 0 0) = Nothing safeArgV v = Just $ argV v -{- | Determinant of the matrix formed by two vectors. -} + +-- | Determinant of the matrix formed by two vectors. detV :: Point2 -> Point2 -> Float {-# INLINE detV #-} detV (V2 x1 y1) (V2 x2 y2) = x1 * y2 - y1 * x2 -{- | Given an angle in radians, anticlockwise from +ve x-axis, - - returns the corresponding unit vector. -} + +{- | Given an angle in radians, anticlockwise from +ve x-axis, + - returns the corresponding unit vector. +-} unitVectorAtAngle :: Float -> Point2 {-# INLINE unitVectorAtAngle #-} unitVectorAtAngle r = V2 (cos r) (sin r) + -- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. rotateV :: Float -> Point2 -> Point2 -rotateV r (V2 x y) = V2 - (x * cos r - y * sin r) - (x * sin r + y * cos r) +rotateV r (V2 x y) = + V2 + (x * cos r - y * sin r) + (x * sin r + y * cos r) {-# INLINE rotateV #-} + rotateVAround :: Point2 -> Float -> Point2 -> Point2 rotateVAround p r q = rotateV r (q -.- p) +.+ p {-# INLINE rotateVAround #-} + -- | Convert degrees to radians degToRad :: Float -> Float degToRad d = d * pi / 180 {-# INLINE degToRad #-} + -- | Convert radians to degrees radToDeg :: Float -> Float radToDeg r = r * 180 / pi {-# INLINE radToDeg #-} + -- | Normalize an angle to be between 0 and 2*pi radians normalizeAngle :: Float -> Float {-# INLINE normalizeAngle #-} -normalizeAngle f - | f >= 0 && f < 2*pi = f +normalizeAngle f + | f >= 0 && f < 2 * pi = f | otherwise = f - 2 * pi * floor' (f / (2 * pi)) - where + where floor' :: Float -> Float floor' x = fromIntegral (floor x :: Int) -{- | Rotate vector by pi/2 clockwise. -} + +-- | Rotate vector by pi/2 clockwise. vNormal :: Point2 -> Point2 {-# INLINE vNormal #-} vNormal (V2 x y) = V2 y (negate x) -{- | Negate a vector. -} + +-- | Negate a vector. vInverse :: Point2 -> Point2 -vInverse (V2 x y) = V2 (-x) (-y) -{- | Normalize a vector safely: on (0,0) return (0,0). -} +vInverse (V2 x y) = V2 (- x) (- y) + +-- | Normalize a vector safely: on (0,0) return (0,0). squashNormalizeV :: Point2 -> Point2 {-# INLINE squashNormalizeV #-} -squashNormalizeV p +squashNormalizeV p | magV p == 0 = V2 0 0 - | otherwise = (1/magV p ) *.* p -{- | Normalize a vector safely: on (0,0) return Nothing. -} + | otherwise = (1 / magV p) *.* p + +-- | Normalize a vector safely: on (0,0) return Nothing. safeNormalizeV :: Point2 -> Maybe Point2 {-# INLINE safeNormalizeV #-} -safeNormalizeV p +safeNormalizeV p | magV p == 0 = Nothing - | otherwise = Just $ (1/magV p ) *.* p -{- | Magnitude of a vector. -} + | otherwise = Just $ (1 / magV p) *.* p + +-- | Magnitude of a vector. magV :: Point2 -> Float {-# INLINE magV #-} -magV (V2 x y) = sqrt $ x^(2::Int) + y^(2::Int) +magV (V2 x y) = sqrt $ x ^ (2 :: Int) + y ^ (2 :: Int) + {- | Magnitude of the cross product of two vectors. -Identical to detV. -} +Identical to detV. +-} crossV :: Point2 -> Point2 -> Float -crossV (V2 ax ay) (V2 bx by) = ax*by - ay*bx -{- | TO CHECK Orthographic projection of one vector onto another. -} +crossV (V2 ax ay) (V2 bx by) = ax * by - ay * bx + +-- | TO CHECK Orthographic projection of one vector onto another. projV :: Point2 -> Point2 -> Point2 -projV fromv onv - | den == 0 = error "tried projecting onto zero vector" +projV fromv onv + | den == 0 = error "tried projecting onto zero vector" | otherwise = (fromv `dotV` onv) / den *.* onv where den = onv `dotV` onv + -- | Return distance between two points. dist :: Point2 -> Point2 -> Float {-# INLINE dist #-} dist !p1 !p2 = magV (p2 -.- p1) + -- | Finds a new angle a given fraction between two other angles -tweenAngles - :: Float - -> Float - -> Float - -> Float +tweenAngles :: + Float -> + Float -> + Float -> + Float {-# INLINE tweenAngles #-} tweenAngles frac a1 a2 | abs (a1 - a2) < pi = frac * (a1 - a2) + a2 @@ -161,8 +193,8 @@ tweenAngles frac a1 a2 where go frac' a1' a2' | abs (a1' - a2') < pi = frac' * (a1' - a2') + a2' - | a1' > a2' = go frac' (a1' - 2*pi) a2' - | otherwise = go frac' a1' (a2' - 2*pi) + | a1' > a2' = go frac' (a1' - 2 * pi) a2' + | otherwise = go frac' a1' (a2' - 2 * pi) xV2 :: Point2 -> Float {-# INLINE xV2 #-} diff --git a/src/IntMapHelp.hs b/src/IntMapHelp.hs index deec9e923..299596442 100644 --- a/src/IntMapHelp.hs +++ b/src/IntMapHelp.hs @@ -2,74 +2,80 @@ --{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + {- | WARNING: orphan instances concerning Aeson classes and Data.Strict.IntMap datatypes have been introduced. The warnings have been disabled. - -} +-} module IntMapHelp - ( module Data.Strict.IntMap - --( module Data.IntMap.Strict - , newKey - , insertNewKey - , insertWithNewKeys - , unsafeSwapKeys - , safeSwapKeys - , findIndex - ) where -import GHC.Generics +-- ( module Data.Strict.IntMap + ( + module Data.IntMap.Strict, + newKey, + insertNewKey, + insertWithNewKeys, + unsafeSwapKeys, + safeSwapKeys, + findIndex, +) where + import Data.Aeson +import Data.IntMap.Strict +import GHC.Generics import LensHelp ---import Data.IntMap.Strict - -import Data.Strict.IntMap -import Data.Strict.Containers.Lens +--import Data.Strict.IntMap +--import Data.Strict.Containers.Lens --import qualified Data.Strict.IntMap as IM --import qualified Data.Strict.IntMap.Autogen.Strict as IM --deriving instance Generic (IntMap a) ---deriving instance (Generic a) => Generic (IM.IntMap a) -instance ToJSON1 IntMap where - liftToJSON t tol = liftToJSON to' tol' . toList - where - to' = liftToJSON2 toJSON toJSONList t tol - tol' = liftToJSONList2 toJSON toJSONList t tol - - liftToEncoding t tol = liftToEncoding to' tol' . toList - where - to' = liftToEncoding2 toEncoding toEncodingList t tol - tol' = liftToEncodingList2 toEncoding toEncodingList t tol - -instance ToJSON a => ToJSON (IntMap a) where - toJSON = toJSON1 - toEncoding = toEncoding1 -instance FromJSON a => FromJSON (IntMap a) where - parseJSON = fmap fromList . parseJSON +--instance ToJSON1 IntMap where +-- liftToJSON t tol = liftToJSON to' tol' . toList +-- where +-- to' = liftToJSON2 toJSON toJSONList t tol +-- tol' = liftToJSONList2 toJSON toJSONList t tol +-- +-- liftToEncoding t tol = liftToEncoding to' tol' . toList +-- where +-- to' = liftToEncoding2 toEncoding toEncodingList t tol +-- tol' = liftToEncodingList2 toEncoding toEncodingList t tol +-- +--instance ToJSON a => ToJSON (IntMap a) where +-- toJSON = toJSON1 +-- toEncoding = toEncoding1 +--instance FromJSON a => FromJSON (IntMap a) where +-- parseJSON = fmap fromList . parseJSON --instance ToJSON a => ToJSON (IntMap a) where -- toEncoding = genericToEncoding defaultOptions {- | Find a key value one higher than any key in the map, or zero if the map is - - empty -} + - empty +-} newKey :: IntMap a -> Int newKey = maybe 0 ((+ 1) . fst) . lookupMax -{- | Insert an element with some new key. -} + +-- | Insert an element with some new key. insertNewKey :: a -> IntMap a -> IntMap a insertNewKey x m = case lookupMax m of - Nothing -> singleton 0 x - Just (k,_) -> insert (k+1) x m -{- | Insert a list of values with new keys -} + Nothing -> singleton 0 x + Just (k, _) -> insert (k + 1) x m + +-- | Insert a list of values with new keys insertWithNewKeys :: [a] -> IntMap a -> IntMap a -insertWithNewKeys xs m = union m $ fromList $ zip [newKey m..] xs -{- | Swaps two keys. Unsafe: assumes both keys exist. -} +insertWithNewKeys xs m = union m $ fromList $ zip [newKey m ..] xs + +-- | Swaps two keys. Unsafe: assumes both keys exist. unsafeSwapKeys :: Int -> Int -> IntMap a -> IntMap a unsafeSwapKeys i j m = insert i (m ! j) $ insert j (m ! i) m safeSwapKeys :: Int -> Int -> IntMap a -> IntMap a -safeSwapKeys i j m = m - & at i .~ (m ^? ix j) - & at j .~ (m ^? ix i) +safeSwapKeys i j m = + m + & at i .~ (m ^? ix j) + & at j .~ (m ^? ix i) -- ideally this should short circuit, I am not sure whether it does or not -- though diff --git a/src/TreeHelp.hs b/src/TreeHelp.hs index 2b59c907f..654703cd6 100644 --- a/src/TreeHelp.hs +++ b/src/TreeHelp.hs @@ -1,195 +1,190 @@ {- Helpers for the manipulation of rose trees. Throughout, the _trunk_ refers to successive first children in the tree. -For example, in the tree +For example, in the tree > Node a [ Node b [], Node c [Node d []] ] the nodes in the trunk are [a,b]. + +Partial functions are annotated as such. -} -module TreeHelp - ( module Data.Tree - , module Data.Tree.Lens - , applyToSubtree - , applyToSubforest - , treeFromPost - , treePost - , treeFromTrunk - , splitTrunk - , applyToRandomNode - , addToTrunk - , inorderNumberTree - , updateSingleNodes - , updateAllNodes - , updateRandNode - , safeUpdateSingleNode - , msafeUpdateSingleNode - , numTraversable - ) where +module TreeHelp ( + module Data.Tree, + module Data.Tree.Lens, + applyToSubtree, + applyToSubforest, + treeFromPost, + treePost, + treeFromTrunk, + splitTrunk, + applyToRandomNode, + addToTrunk, + inorderNumberTree, + updateSingleNodes, + updateAllNodes, + updateRandNode, + safeUpdateSingleNode, + numTraversable, +) where + +import Control.Lens +import Data.Maybe +import Data.Traversable +import Data.Tree +import Data.Tree.Lens import RandomHelp -import Data.Traversable -import Data.Maybe -import Data.Tree.Lens -import Data.Tree -import Control.Lens - -{- | Creates a linear tree. -Safe. -} +-- | Creates a linear tree. treeFromPost :: [a] -> a -> Tree a treeFromPost xs = treeFromTrunk xs . pure {- | Creates a linear tree from a list. -Unsafe. -} +Partial function. +-} treePost :: [a] -> Tree a treePost xs = treeFromPost (init xs) (last xs) -{- | Creates a tree with one trunk branch, -input as a list, that ends in another tree. -} -treeFromTrunk - :: [a] -- ^ The trunk - -> Tree a -- ^ The end of the tree - -> Tree a +{- | Creates a tree with one trunk branch, +input as a list, that ends in another tree. +-} +treeFromTrunk :: + -- | The trunk + [a] -> + -- | The end of the tree + Tree a -> + Tree a treeFromTrunk = flip $ foldr f where f x t = Node x [t] --- find use for? ----- | Consider defining this using generalised recursion patterns ---treeSize :: Tree a -> Int ---treeSize = length . flatten - {- | Applies a function to a specific node determined by a list of indices. -Unsafe (partial function). -} +Partial. +-} applyToNode :: [Int] -> (a -> a) -> Tree a -> Tree a applyToNode is = applyToSubtree is . over root {- | Applies a function to a specific subtree determined by a list of indices. -Unsafe (partial function). -} +Partial. +-} applyToSubtree :: [Int] -> (Tree a -> Tree a) -> Tree a -> Tree a applyToSubtree [] f t = f t -applyToSubtree (i:is) f (Node x xs) = Node x (xs & ix i %~ applyToSubtree is f) +applyToSubtree (i : is) f (Node x xs) = Node x (xs & ix i %~ applyToSubtree is f) {- | Applies a function to a specific subforest determined by a list of indices. -Unsafe (partial function). -} +Partial. +-} applyToSubforest :: [Int] -> ([Tree a] -> [Tree a]) -> Tree a -> Tree a applyToSubforest is = applyToSubtree is . over branches ---applyToSubforest [] f (Node p cs) = Node p (f cs) ---applyToSubforest (i:is) f (Node x xs) = Node x (ys ++ [applyToSubforest is f z] ++ zs) --- where --- (ys, z:zs) = splitAt i xs - --- do not delete: find use for ---{- | ---Applies a function to the first node along a trunk that satisfies a given property. ----} ---applyToSubTrunkBy :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a ---applyToSubTrunkBy cond f (Node x (t:ts)) --- | cond x = f (Node x (t:ts)) --- | otherwise = Node x (applyToSubTrunkBy cond f t : ts) ---applyToSubTrunkBy _ _ t = t +{- | Transforms a tree everywhere a property is satisfied. +Can perform multiple transformations in different branches. +However, does not perform any further transformation within a transformed subtree. +Thus this always terminate on finite trees. +-} updateAllNodes :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a updateAllNodes f update t@(Node x ts) - | f x = update t + | f x = update t | otherwise = updateChildren where updateChildren = Node x (map (updateAllNodes f update) ts) - --- gives the list of all updates to a single node --- there must be a better way of doing something like this +{- | For each node within the input tree that satisfies a property, +produce a tree with the subtree starting at that node transformed by a function. +Produces an empty list if no nodes satisfy the property. +Depth first. +-} updateSingleNodes :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> [Tree a] updateSingleNodes f update t@(Node x ts) - | f x = update t : updateChildren + | f x = update t : updateChildren | otherwise = updateChildren where updateChildren = map (Node x) (subMap (updateSingleNodes f update) ts) -mupdateSingleNodes :: Monad m => (a -> Bool) -> (Tree a -> m (Tree a)) -> Tree a -> [m (Tree a)] -mupdateSingleNodes f update t@(Node x ts) - | f x = update t : updateChildren - | otherwise = updateChildren - where - updateChildren = map (fmap $ Node x) (msubMap (mupdateSingleNodes f update) ts) - +{- | Chooses a random node that satisfies a property, +produces a tree with the subtree starting at that node transformed by a function. +Partial, undefined if no node satisfies the property. +-} updateRandNode :: RandomGen g => (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> State g (Tree a) updateRandNode t f = takeOne . updateSingleNodes t f +{- | Finds the (depth) first node that satisfies a property, +produces a tree with the subtree starting at that node transformed by a function. +Produces the original tree if no nodes satisfy the property. +-} safeUpdateSingleNode :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a safeUpdateSingleNode f g t = fromMaybe t $ listToMaybe $ updateSingleNodes f g t -msafeUpdateSingleNode :: Monoid b => (a -> Bool) -> (Tree a -> (b, Tree a)) -> Tree a -> (b,Tree a) -msafeUpdateSingleNode f g t = fromMaybe (mempty,t) $ listToMaybe $ mupdateSingleNodes f g t - -msubMap :: Functor m => (a -> [m a]) -> [a] -> [m [a]] -msubMap f (x:xs) = (f x <&> fmap (: xs)) ++ ( fmap (x :) <$> msubMap f xs ) -msubMap _ [] = [] - subMap :: (a -> [a]) -> [a] -> [[a]] -subMap f (x:xs) = (f x <&> (: xs)) ++ ( (x :) <$> subMap f xs ) +subMap f (x : xs) = (f x <&> (: xs)) ++ ((x :) <$> subMap f xs) subMap _ [] = [] -- find use for? --zipTree :: Tree a -> Tree b -> Tree (a,b) --zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys -{- | Makes each node into its child number, i.e. the index it has -in the list of children of its parent. -} +{- | Makes each node into its child number, i.e. the index it has +in the list of children of its parent. +-} treeChildNums :: Tree a -> Tree Int treeChildNums = setRoot 0 - where + where setRoot :: Int -> Tree a -> Tree Int - setRoot i (Node _ xs) = Node i (zipWith setRoot [0..] xs) + setRoot i (Node _ xs) = Node i (zipWith setRoot [0 ..] xs) -{- | Makes each node into its path, i.e. the list of indices that, -when followed from the root, lead to the node. -} +{- | Makes each node into its path, i.e. the list of indices that, +when followed from the root, lead to the node. +-} treePaths :: Tree a -> Tree [a] treePaths (Node x xs) = (x :) <$> Node [] (map treePaths xs) {- | Picks a random path in the tree. -Uniform probability that the path leads to any specific node. -} +Uniform probability that the path leads to any specific node. +-} randomPath :: RandomGen g => Tree a -> State g [Int] randomPath = takeOne . flatten . treePaths . treeChildNums -{- | Apply a function to the value of a node; -the node is picked uniformly at random. -} +{- | Apply a function to the value of a node; +the node is picked uniformly at random. +-} applyToRandomNode :: RandomGen g => (a -> a) -> Tree a -> State g (Tree a) applyToRandomNode f t = do p <- randomPath t return $ applyToNode p f t -{- | Add a forest to the end of a tree (along the trunk). -} +-- | Add a forest to the end of a tree (along the trunk). addToTrunk :: Tree a -> [Tree a] -> Tree a addToTrunk (Node x []) f = Node x f -addToTrunk (Node x (t:ts)) f = Node x (addToTrunk t f : ts) +addToTrunk (Node x (t : ts)) f = Node x (addToTrunk t f : ts) -{- | Find the depth of a tree along the trunk. -} +-- | Find the depth of a tree along the trunk. trunkDepth :: Tree a -> Int trunkDepth (Node _ []) = 0 -trunkDepth (Node _ (x:_)) = trunkDepth x + 1 +trunkDepth (Node _ (x : _)) = trunkDepth x + 1 -{- | Split a tree at a given point along its trunk. -} -splitTrunkAt - :: Int -- ^ Split depth - -> Tree a -> (Tree a, [Tree a]) -splitTrunkAt 0 (Node x xs) = (Node x [],xs) -splitTrunkAt i (Node y (x:xs)) = - let (t, ts) = splitTrunkAt (i-1) x - in (Node y (t : xs) , ts) +-- | Split a tree at a given point along its trunk. +splitTrunkAt :: + -- | Split depth + Int -> + Tree a -> + (Tree a, [Tree a]) +splitTrunkAt 0 (Node x xs) = (Node x [], xs) +splitTrunkAt i (Node y (x : xs)) = + let (t, ts) = splitTrunkAt (i -1) x + in (Node y (t : xs), ts) splitTrunkAt _ (Node _ []) = error "Trying to split to short a trunk" -{- | Split a tree at a random point along its trunk. -} +-- | Split a tree at a random point along its trunk. splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a]) splitTrunk t = do i <- state $ randomR (0, trunkDepth t) return $ splitTrunkAt i t -numTraversable :: Traversable t => t a -> t (a,Int) +numTraversable :: Traversable t => t a -> t (a, Int) numTraversable = snd . mapAccumL f 0 where - f i x = (i+1,(x,i)) + f i x = (i + 1, (x, i)) -- untested -inorderNumberTree :: Tree a -> Tree (a,Int) +inorderNumberTree :: Tree a -> Tree (a, Int) inorderNumberTree = numTraversable