From 736e78441ae8b0cffa610de4baa7248f726cf69c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 10 Jun 2016 02:14:31 +0200 Subject: refactoring & combat rounds --- default.nix | 3 +- sequence.cabal | 2 +- src/Main.hs | 24 +++++++------ src/Sequence/Contact/Archetypes.hs | 59 +++++++++++++++++++++++++----- src/Sequence/Contact/Types.hs | 66 +++++++++++++++++++++++++--------- src/Sequence/Contact/Types/Internal.hs | 22 ++++++++++-- src/Sequence/Types.hs | 52 +++++++++++++-------------- 7 files changed, 160 insertions(+), 68 deletions(-) diff --git a/default.nix b/default.nix index c96e43f..4b974c3 100644 --- a/default.nix +++ b/default.nix @@ -1,8 +1,9 @@ { pkgs ? (import {}) -, compilerName ? "ghc7103" +, compilerName ? "ghc801" }: rec { + # haskellPackages = pkgs.haskell.packages."${compilerName}"; haskellPackages = pkgs.haskell.packages."${compilerName}".override { overrides = self: super: { Shellac = pkgs.haskell.lib.appendPatch super.Shellac (pkgs.writeText "build.patch" '' diff --git a/sequence.cabal b/sequence.cabal index 2def576..931cba6 100644 --- a/sequence.cabal +++ b/sequence.cabal @@ -19,7 +19,7 @@ executable sequence main-is: Main.hs other-modules: Sequence.Types -- other-extensions: - build-depends: base >=4.8 && <5 + build-depends: base >=4.9 && <5 , Shellac , Shellac-haskeline , data-default diff --git a/src/Main.hs b/src/Main.hs index b7c6a6e..f46fd3e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -32,6 +32,7 @@ import Data.Bool import Data.Function import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe import Sequence.Types import Sequence.Contact.Types @@ -92,11 +93,11 @@ stateOutline st faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities) factionIndex id = fromJust $ elemIndex (view faction' $ faction id) factions rowGs = do - rowGroup'@((review seqVal' -> seqVal, _):_) <- protoRows + rowGroup'@((seq, _):_) <- protoRows let rowGroup = map snd rowGroup' factionColumn i = [evalState ?? st $ toName x | x <- rowGroup, factionIndex x == i ] - return . colsAllG top $ [seqVal] : map factionColumn [0..(length factions - 1)] + return . colsAllG top $ [show $ view seqVal seq] : map factionColumn [0..(length factions - 1)] -- Query state listFactions, listEntities :: Sh GameState () @@ -195,12 +196,13 @@ factionSeqVal :: Completable Faction -> Sh GameState () factionSeqVal = withArg $ \qFaction -> use gEntities >>= mapM_ (entitySeqVal') . Map.keys . Map.filter ((==) qFaction . view eFaction) entitySeqVal' :: EntityIdentifier -> Sh GameState () -entitySeqVal' ident = do - entity <- preuse (gEntities . ix ident) - let sVal = preview (eStats . sSeqVal) =<< entity - case (,) <$> entity <*> sVal of - Nothing -> return () - Just (entity, sVal) -> do - name <- toName ident - (newEntity, view (seqVal . re _Just) -> val) <- evalFormula name entity sVal - gEntities . at ident .= Just (newEntity & set eSeqVal val) +entitySeqVal' ident = void . runMaybeT $ do + entity <- MaybeT $ preuse (gEntities . ix ident) + sVal <- MaybeT . return $ preview (eStats . sSeqVal) entity + name <- toName ident + round <- use gRound + (newEntity, sNum) <- evalFormula name entity sVal + let val = Just $ def + & set seqRound round + & set seqVal (Just sNum) + gEntities . at ident .= Just (newEntity & set eSeqVal val) diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs index 3e9b416..ff37fdb 100644 --- a/src/Sequence/Contact/Archetypes.hs +++ b/src/Sequence/Contact/Archetypes.hs @@ -4,6 +4,11 @@ module Sequence.Contact.Archetypes where import Control.Lens +import Control.Monad.Except +import Control.Monad.State +import Control.Monad.Trans +import Control.Monad.Trans.Maybe + import Sequence.Contact.Types import Sequence.Formula @@ -14,6 +19,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Default +import Data.Maybe +import Data.Ratio import Data.List @@ -37,6 +44,9 @@ archetypes = [ ("Mensch", human) , ("Milizenschläger", milizenschlaeger) ] +cTable :: Ord v => [(Integer, Integer, v)] -> Table v +cTable = Map.fromList . map (\(from, to, value) -> (value, (abs (to - from) + 1) % 100)) + human = Humanoid { _sAStrength = vStrength @@ -86,17 +96,48 @@ human = Humanoid , _sPainTolerance = vMass `quot'` 2 + vWillpower , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance - , _sHitzones = [ ("Kopf", 0.05) - , ("Torso", 0.49) - , ("Rechter Arm", 0.08) - , ("Linker Arm", 0.08) - , ("Unterleib", 0.10) - , ("Rechtes Bein", 0.10) - , ("Linkes Bein", 0.10) - ] - , _sDamage = const 0 + , _sHitzones = cTable [ (1, 5, "Kopf") + , (6, 54, "Torso") + , (55, 62, "Rechter Arm") + , (63, 70, "Linker Arm") + , (71, 80, "Unterleib") + , (81, 90, "Rechtes Bein") + , (91, 100, "Linkes Bein") + ] , _sArmor = const def + , _sCripple = fromJust . flip Map.lookup [ ("Kopf", def + & set seVal (sDamage' "Kopf" . to return) + & set seBar (sMaxVitality . mapping (scaled 0.5)) + & set seEffect (cTable [ (1, 10, Effect "Tod" headshot) + , (11, 25, effect "Blind") + , (26, 35, effect "Blind, Rechts") + , (36, 45, effect "Blind, Links") + , (46, 75, effect "Taub") + , (76, 100, effect "Bewusstlos – 1w10 Runden") + ]) + ) + , ("Torso", def) + , ("Rechter Arm", def) + , ("Linker Arm", def) + , ("Unterleib", def) + , ("Rechtes Bein", def) + , ("Linkes Bein", def) + ] + + , _sDamage = const 0 + , _sFatigue = 0 + + , _sPainShock = def + , _sFatigueShock = def } + where + headshot = runMaybeT $ do + maxVitality <- (MaybeT . preview $ ctx . sMaxVitality) >>= lift + currentDmg <- MaybeT . preview $ ctx . sDamage' "Kopf" + allDmg <- MaybeT . preview $ ctx . sTotalDamage + let dmg = currentDmg + (maxVitality - allDmg) + dmg' = if dmg >= 0 then dmg else 0 + MaybeT . previews ctx $ set (sDamage' "Kopf") dmg' dog = Quadruped { _sAStrength = vStrength diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs index cd1bc02..a0add1a 100644 --- a/src/Sequence/Contact/Types.hs +++ b/src/Sequence/Contact/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts #-} module Sequence.Contact.Types ( module Sequence.Contact.Types @@ -22,6 +22,8 @@ import Data.String (IsString(..)) import Data.Function (on) import Data.Maybe import Data.Ratio +import Data.List +import Data.Ord import Control.Monad.Reader (ask) import Control.Monad.State @@ -73,21 +75,36 @@ instance Default Modifier where makePrisms ''Effect +effectName :: Lens' Effect String +effectName = _Effect . _1 . iso CI.original CI.mk + instance Eq Effect where - (==) = (==) `on` (view $ _Effect . _1) + (==) = (==) `on` (view effectName) instance Ord Effect where - compare = compare `on` (view $ _Effect . _1) + compare = compare `on` (view effectName) instance Default Effect where - def = Effect "" pure + def = Effect "" $ preview ctx + +effect :: String -> Effect +effect str = def & set effectName str + +makePrisms ''SeqVal +makeLenses ''SeqVal + +instance Default SeqVal where + def = SeqVal { _seqRound = 0 + , _seqVal = Nothing + , _seqEpsilon = False + } makeLenses ''ShockEffect instance Default ShockEffect where def = ShockEffect { _seApplied = False - , _seVal = pure Nothing - , _seBar = pure Nothing + , _seVal = ignored + , _seBar = ignored , _seEffect = def } @@ -96,17 +113,23 @@ makeLenses ''Stats instance Default Stats where def = Prop { _sHitzones = [("Volumen", 1)] + , _sArmor = const def + , _sCripple = const def + , _sDamage = const 0 , _sFatigue = 0 - , _sCripple = const def - , _sArmor = const def + + , _sSequence = Nothing + + , _sPainShock = def + , _sFatigueShock = def , _sExtraSkills = [] , _sModifiers = [] } applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect -applyModifier effectName modifier = Effect (CI.mk effectName) $ return . apply +applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply where apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier] @@ -121,22 +144,33 @@ vCharisma = val sACharisma "Charisma?" True vPerception = val sAPerception "Wahrnehmung?" True vWillpower = val sAWillpower "Entschlossenheit?" True -scaled :: (Real a, Fractional a, Integral b) => Ratio b -> Iso' a a -scaled (realToFrac -> ratio) = iso (* ratio) (/ ratio) +scaled :: Ratio Int -> Iso' Int Int +scaled r = iso (\x -> floor $ x % 1 * r) (\x -> round $ x % 1 / r) -sDamage' :: String -> Traversal' Stats Int -sDamage' (view hitzone -> zone) = sDamage . ix zone +sDamage' :: Hitzone -> Traversal' Stats Int +sDamage' zone = sDamage . ix zone -sCripple' :: String -> Traversal' Stats ShockEffect -sCripple' (view hitzone -> zone) = sCripple . ix zone +sCripple' :: Hitzone -> Traversal' Stats ShockEffect +sCripple' zone = sCripple . ix zone sTotalDamage :: Lens' Stats Int -sTotalDamage = lens retrieve undefined +sTotalDamage = lens retrieve $ flip spread where retrieve = do hitzones <- Map.keys <$> view sHitzones damageMap <- view sDamage return . sum $ pure damageMap <*> hitzones + spread dmg = execState $ do + hitzones <- Map.keys <$> use sHitzones + damageMap <- use sDamage + totalDamage <- use sTotalDamage + let dmg' = dmg - totalDamage + (d, r) = dmg' `divMod` length hitzones + min = snd $ (if dmg' < 0 then maximumBy else minimumBy) (compare `on` fst) [(damageMap zone, zone) | zone <- hitzones] + damageMap' z + | z == min = damageMap z + d + r + | otherwise = damageMap z + d + sDamage .= damageMap' sDead :: Fold Stats (FormulaM Stats Bool) sDead = folding $ do diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs index 9929801..7e9be2b 100644 --- a/src/Sequence/Contact/Types/Internal.hs +++ b/src/Sequence/Contact/Types/Internal.hs @@ -7,6 +7,7 @@ import Sequence.Formula (Formula, FormulaM, Table) import Data.Map (Map) import Data.Set (Set) import Data.Ratio +import Data.Monoid import Control.Lens @@ -42,12 +43,19 @@ data Test = Test data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) -data Effect = Effect (CI String) (Stats -> FormulaM Stats Stats) +data Effect = Effect (CI String) (FormulaM Stats (Maybe Stats)) + +data SeqVal = SeqVal + { _seqRound :: Int + , _seqVal :: Maybe Int + , _seqEpsilon :: Bool + } + deriving (Show, Ord, Eq) data ShockEffect = ShockEffect { _seApplied :: Bool - , _seVal :: FormulaM Stats (Maybe Int) - , _seBar :: FormulaM Stats (Maybe Int) + , _seVal :: Getting (First (Formula Stats)) Stats (Formula Stats) + , _seBar :: Getting (First (Formula Stats)) Stats (Formula Stats) , _seEffect :: Table Effect } @@ -62,6 +70,8 @@ data Stats = Prop , _sPainShock :: ShockEffect , _sFatigueShock :: ShockEffect + , _sSequence :: Maybe SeqVal + , _sExtraSkills :: Map (CI String) (FormulaM Stats Test) , _sModifiers :: Set Modifier } @@ -120,6 +130,8 @@ data Stats = Prop , _sDamage :: Hitzone -> Int , _sFatigue :: Int + , _sSequence :: Maybe SeqVal + , _sPainShock :: ShockEffect , _sFatigueShock :: ShockEffect @@ -156,6 +168,8 @@ data Stats = Prop , _sDamage :: Hitzone -> Int , _sFatigue :: Int + , _sSequence :: Maybe SeqVal + , _sPainShock :: ShockEffect , _sFatigueShock :: ShockEffect @@ -192,6 +206,8 @@ data Stats = Prop , _sDamage :: Hitzone -> Int , _sFatigue :: Int + , _sSequence :: Maybe SeqVal + , _sPainShock :: ShockEffect , _sFatigueShock :: ShockEffect diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs index 02389a1..33bbc2a 100644 --- a/src/Sequence/Types.hs +++ b/src/Sequence/Types.hs @@ -3,11 +3,10 @@ module Sequence.Types ( GameState, gEntities, gEntityNames, gFocus, gNextId' , Faction, faction, faction' - , SeqVal(..), seqVal, seqVal' , Entity(..), eFaction, eSeqVal, eStats , EntityName(..), entityName , EntityIdentifier(..), entityId, entityId' - , inhabitedFactions, priorityQueue, tip, insertEntity, gFocus' + , inhabitedFactions, priorityQueue, tip, insertEntity, gFocus', gRound ) where import Control.Lens @@ -26,11 +25,14 @@ import qualified Data.Bimap as Bimap import Control.Monad.Reader import Control.Monad.State +import Control.Monad.Trans.Maybe import Data.List import Data.Maybe import Data.Tuple import Data.Ord +import Data.Semigroup (Min(..)) +import Data.Monoid import Sequence.Contact.Types import Sequence.Formula ((:<:)(..)) @@ -59,30 +61,23 @@ faction' = lens (CI.original . fromMaybe unaligned . view faction) (\s a -> s { | otherwise = Just str' -newtype SeqVal = SeqVal { _seqVal :: Int } - deriving (Show, Ord, Eq, Num, Integral, Enum, Real) - -seqVal :: Integral a => Iso' a SeqVal -seqVal = iso (SeqVal . fromIntegral) (fromIntegral . _seqVal) - -seqVal' :: Prism' String SeqVal -seqVal' = _Show . seqVal - - data Entity = Entity - { _eSeqVal :: Maybe SeqVal - , _eFaction :: Faction + { _eFaction :: Faction , _eStats :: Stats + , _eNotes :: [String] } makeLenses ''Entity instance Default Entity where def = Entity - { _eSeqVal = def - , _eFaction = def + { _eFaction = def , _eStats = def + , _eNotes = [] } +eSeqVal :: Lens' Entity (Maybe SeqVal) +eSeqVal = eStats . sSequence + instance (Entity :<: a) => Stats :<: a where ctx' = ctx' . eStats @@ -132,17 +127,11 @@ tip :: Fold GameState EntityIdentifier tip = priorityQueue . folding (fmap snd . listToMaybe) gFocus' :: Traversal' GameState Entity -gFocus' modifyFocus = do - focusIdent <- view gFocus - case focusIdent of - Nothing -> pure <$> ask - Just focusIdent -> do - focus <- view (gEntities . at focusIdent) - case focus of - Nothing -> pure <$> ask - Just focus -> do - st <- ask - return $ flip (set $ gEntities . at focusIdent) st . Just <$> modifyFocus focus +gFocus' modifyFocus st = (flip runReader st) . (maybe (asks pure) return =<<) . runMaybeT $ do + focusIdent <- MaybeT $ view gFocus + focus <- MaybeT $ view (gEntities . at focusIdent) + st <- ask + return $ flip (set $ gEntities . at focusIdent) st . Just <$> modifyFocus focus -- gFocus' = prism' getFocus setFocus -- where @@ -163,3 +152,12 @@ insertEntity entity = execState $ do gEntities . at identifier ?= entity gNextId %= succ +gRound :: Lens' GameState Int +gRound = lens lowestRound $ flip trimBelow + where + lowestRound = getMin . (<> Min 0) . view (gEntities . each . eStats . sSequence . _Just . seqRound . _Unwrapped) + trimBelow = over (gEntities . each . eStats . sSequence) . trimBelow' + trimBelow' cutoff = runReader . runMaybeT $ do + round <- MaybeT . preview $ _Just . seqRound + guard $ round >= cutoff + MaybeT ask -- cgit v1.2.3