From fbaf4d9da45f714c32f410d3b5785fd06504325a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 4 Jun 2016 18:06:36 +0200 Subject: archetypes & cleanup --- src/Main.hs | 20 ++++++++- src/Sequence/Contact/Archetypes.hs | 90 ++++++++++++++++++++++++++++++++++++++ src/Sequence/Contact/Types.hs | 12 ++++- src/Sequence/Types.hs | 40 +++++++++++++---- src/Sequence/Utils.hs | 30 +++++++++---- 5 files changed, 172 insertions(+), 20 deletions(-) create mode 100644 src/Sequence/Contact/Archetypes.hs (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 8f955bb..9ea7a49 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -32,11 +32,14 @@ import Data.Function import Control.Monad.State.Strict import Sequence.Types +import Sequence.Contact.Archetypes import Sequence.Utils import Sequence.Formula import Text.Layout.Table +import Text.Read (readMaybe) + main :: IO () main = do historyFile <- getUserCacheFile "sequence" "history" @@ -44,7 +47,7 @@ main = do let description = initialShellDescription { historyFile = Just historyFile - , prompt = \st -> return $ maybe "" (++ " ") ((evalState ?? st) . toName <$> view tip st) ++ "→ " + , prompt = \st -> return $ maybe "" (++ " ") ((evalState ?? st) . toName <$> view gFocus st) ++ "→ " , beforePrompt = gets stateOutline >>= (\str -> if null str then return () else shellPutStrLn str) , commandStyle = OnlyCommands , shellCommands = [ exitCommand "exit" @@ -57,6 +60,8 @@ main = do , cmd "factions" listFactions "List all inhabited factions" , cmd "members" listFaction "List all members of a faction" , cmd "align" alignEntity "Align the focused entity to a faction – creating it, if necessary" + , cmd "name" nameEntity "Name the current entity overriding previous name assignments" + , cmd "spawn" spawnEntity "Create a new entity from an archetype focusing on it" ] } void $ runShell description haskelineBackend (def :: GameState) @@ -95,7 +100,7 @@ blur = gFocus .= Nothing -- Manual focus setFocus :: Completable EntityIdentifier -> Sh GameState () -setFocus = withArg $ \ident -> gFocus .= Just ident +setFocus = withArg $ \ident -> gFocus ?= ident -- Drop information remove :: Sh GameState () @@ -106,3 +111,14 @@ remove = withFocus $ \ident -> do gEntities %= Map.delete ident gEntityNames %= Bimap.delete ident blur + +-- Manage Entity +spawnEntity :: Completable Entity -> Sh GameState () +spawnEntity = withArg $ \entity -> do + identifier <- use gNextId' + modify $ insertEntity entity + gFocus ?= identifier + +nameEntity :: String -> Sh GameState () +nameEntity ('#':_) = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#’)" +nameEntity name = withFocus $ \ident -> modifying gEntityNames $ Bimap.insert ident (name ^. entityName) diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs new file mode 100644 index 0000000..94addce --- /dev/null +++ b/src/Sequence/Contact/Archetypes.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses #-} + +module Sequence.Contact.Archetypes where + +import Control.Lens + +import Sequence.Contact.Types +import Sequence.Formula + +import Sequence.Types +import Sequence.Utils + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Default + +import Data.List + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + + +instance Completion Entity GameState where + completableLabel _ = "" + complete _ _ (CI.foldCase -> prefix) = return . filter (prefix `isPrefixOf`) . map CI.foldedCase $ Map.keys archetypes + +instance Argument Entity GameState where + arg = return . fmap (flip (set eStats) def) . flip Map.lookup archetypes . CI.mk + +archetypes :: Map (CI String) Stats +archetypes = [ ("Mensch", human) + , ("Kind von Mu", childOfMu) + ] + + +human = Humanoid + { _sAStrength = vStrength + , _sAEndurance = vEndurance + , _sAMass = vMass + , _sAReflexes = vReflexes + , _sAMobility = vMobility + , _sADexterity = vDexterity + , _sAIntelligence = vIntelligence + , _sACharisma = vCharisma + , _sAPerception = vPerception + , _sAWillpower = vWillpower + + , _sSArchaicRanged = 20 + vStrength `quot'` 2 + vDexterity `quot'` 2 + vPerception + , _sSFirearms = 15 + vMobility `quot'` 2 + vDexterity `quot'` 2 + vPerception + , _sSHeavyWeapons = vStrength `quot'` 2 + vPerception + , _sSEnergyWeapons = 10 + vMobility `quot'` 2 + vDexterity `quot'` 2 + vPerception + , _sSUnarmedMelee = 30 + vReflexes + vMobility `quot'` 2 + , _sSArmedMelee = 25 + vReflexes + vMobility `quot'` 2 + , _sSThrownWeapons = 25 + vMobility `quot'` 2 + vPerception + , _sSStealth = 5 + vMobility + vDexterity + , _sSThievery = 5 + vDexterity * 2 + vIntelligence + , _sSLockpicking = vDexterity + vIntelligence + , _sSTrapping = vDexterity + vIntelligence + vPerception `quot'` 2 + , _sSSciences = 10 + vIntelligence * 4 + , _sSFirstAid = 10 + vDexterity + vIntelligence * 2 + , _sSMedicine = 5 + vDexterity `quot'` 2 + vIntelligence * 3 + , _sSHumanities = 20 + vIntelligence * 3 + , _sSEngineering = 5 + vDexterity + vIntelligence * 2 + , _sSCraft = 25 + vDexterity * 2 + , _sSInterface = 5 + vIntelligence * 2 + vPerception `quot'` 2 + , _sSSpeech = vIntelligence + vCharisma * 2 + vWillpower `quot'` 2 + , _sSLeadership = 5 + vCharisma * 3 + vWillpower + , _sSHomeEconomics = 25 + vIntelligence + , _sSSurvival = 30 + vReflexes + vMobility + vIntelligence + vPerception + vWillpower `quot'` 2 + , _sSMotorcycle = vReflexes * 2 + vMobility + vWillpower + , _sSWheeled = 15 + vReflexes + vWillpower + , _sSHovercraft = 10 + vReflexes + vWillpower + , _sSAircraft = vReflexes + vWillpower + , _sSSpacecraft = vReflexes + vIntelligence `quot'` 2 + vPerception `quot'` 2 + , _sSWatercraft = 20 + vReflexes `quot'` 2 + vPerception `quot'` 2 + , _sSTracked = 15 + vReflexes + vPerception + , _sSExoskeleton = 30 + vReflexes + vMobility * 2 + vPerception + + , _sMaxVitality = vEndurance * 2 + vMass * 2 + vWillpower + 10 + , _sSeqVal = vReflexes * 2 + vMobility + vPerception + d 10 + , _sPainTolerance = vMass `quot'` 2 + vWillpower + , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance + } + +childOfMu = human + & sAStrength +~ 2 + & sAReflexes +~ 5 + & sAMobility +~ 5 + & sAPerception +~ 2 diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs index b63b369..d3ca31e 100644 --- a/src/Sequence/Contact/Types.hs +++ b/src/Sequence/Contact/Types.hs @@ -38,7 +38,7 @@ data Stats = Prop , _sSHumanities , _sSEngineering , _sSCraft - , _sSInterfacte + , _sSInterface , _sSSpeech , _sSLeadership , _sSHomeEconomics @@ -108,3 +108,13 @@ makeLenses ''Stats instance Default Stats where def = Prop +vStrength = val sAStrength "Stärke?" True +vEndurance = val sAEndurance "Ausdauer?" True +vMass = val sAMass "Masse?" True +vReflexes = val sAReflexes "Reflexe?" True +vMobility = val sAMobility "Beweglichkeit?" True +vDexterity = val sADexterity "Geschicklichkeit?" True +vIntelligence = val sAIntelligence "Intelligenz?" True +vCharisma = val sACharisma "Charisma?" True +vPerception = val sAPerception "Wahrnehmung?" True +vWillpower = val sAWillpower "Entschlossenheit?" True diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs index 4370618..c47136c 100644 --- a/src/Sequence/Types.hs +++ b/src/Sequence/Types.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, ViewPatterns, OverloadedStrings, TemplateHaskell, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, ViewPatterns, OverloadedStrings, TemplateHaskell, GeneralizedNewtypeDeriving #-} module Sequence.Types - ( GameState(..), gEntities, gEntityNames, gFocus + ( GameState, gEntities, gEntityNames, gFocus, gNextId' , Faction, faction, faction' , SeqVal(..), seqVal - , Entity(..), eFaction, eSeqVal + , Entity(..), eFaction, eSeqVal, eStats , EntityName(..), entityName - , EntityIdentifier(..), entityId - , inhabitedFactions, priorityQueue, tip + , EntityIdentifier(..), entityId, entityId' + , inhabitedFactions, priorityQueue, tip, insertEntity ) where import Control.Lens @@ -24,13 +24,16 @@ import qualified Data.Map.Strict as Map import Data.Bimap (Bimap) import qualified Data.Bimap as Bimap +import Control.Monad.State + import Data.List import Data.Maybe import Data.Tuple import Data.Ord import Sequence.Contact.Types - + +import Text.Read (readMaybe) newtype Faction = Faction { _lFaction :: Maybe (CI String) } deriving (Show, Eq, Ord) @@ -75,16 +78,24 @@ instance Default Entity where newtype EntityName = EntityName { _entityName :: CI String } deriving (Show, Eq, Ord) -makeLenses ''EntityName + +entityName :: Iso' String EntityName +entityName = iso (EntityName . CI.mk) (CI.original . _entityName) newtype EntityIdentifier = EntityIdentifier { _entityId :: Integer } - deriving (Show, Eq, Ord) -makeLenses ''EntityIdentifier + deriving (Show, Eq, Ord, Enum) + +entityId :: Iso' Integer EntityIdentifier +entityId = iso EntityIdentifier _entityId + +entityId' :: Prism' String EntityIdentifier +entityId' = prism' (show . _entityId) (fmap EntityIdentifier . readMaybe) data GameState = GameState { _gEntities :: Map EntityIdentifier Entity , _gEntityNames :: Bimap EntityIdentifier EntityName , _gFocus :: Maybe EntityIdentifier + , _gNextId :: EntityIdentifier } makeLenses ''GameState @@ -93,6 +104,7 @@ instance Default GameState where { _gEntities = def , _gEntityNames = Bimap.empty , _gFocus = Nothing + , _gNextId = toEnum 0 } inhabitedFactions :: Getter GameState [Faction] @@ -107,3 +119,13 @@ priorityQueue = to priorityQueue' tip :: Getter GameState (Maybe EntityIdentifier) tip = priorityQueue . to (fmap snd . listToMaybe) + +gNextId' :: Getter GameState EntityIdentifier +gNextId' = gNextId + +insertEntity :: Entity -> GameState -> GameState +insertEntity entity = execState $ do + identifier <- use gNextId + gEntities . at identifier ?= entity + gNextId %= succ + diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs index 274a69d..9fc0ab2 100644 --- a/src/Sequence/Utils.hs +++ b/src/Sequence/Utils.hs @@ -2,7 +2,9 @@ module Sequence.Utils ( withArg, withFocus - , toName, fromName + , toName + , Argument(..) + , Completion(..) , module Sequence.Utils.Ask ) where @@ -10,6 +12,7 @@ import Sequence.Types import Control.Monad.State.Strict +import Control.Applicative import Control.Monad import Control.Lens @@ -28,6 +31,7 @@ import Data.Maybe import Text.Read (readMaybe) import Data.List +import Data.Bool import System.Console.Shell import System.Console.Shell.ShellMonad @@ -49,20 +53,30 @@ withFocus f = use gFocus >>= \focus -> case focus of Just id -> f id unaligned = view faction' def - -toName :: MonadState GameState m => EntityIdentifier -> m String -toName id = fromMaybe (show $ id ^. entityId) . fmap (CI.original . view entityName) . Bimap.lookup id <$> use gEntityNames -fromName :: MonadState GameState m => String -> m (Maybe EntityIdentifier) -fromName (readMaybe -> (Just (EntityIdentifier -> n))) = (n <$) . guard . Map.member n <$> use gEntities -fromName (EntityName . CI.mk -> name) = Bimap.lookupR name <$> use gEntityNames +toName :: MonadState GameState m => EntityIdentifier -> m String +toName ident = do + let number = review entityId' ident + isShadowed <- uses gEntityNames . Bimap.memberR $ view entityName number + let number' = bool id ('#':) isShadowed $ number + fromMaybe number' . fmap (review entityName) . Bimap.lookup ident <$> use gEntityNames instance Completion EntityIdentifier GameState where completableLabel _ = "" complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities instance Argument EntityIdentifier GameState where - arg = fromName + arg = \str -> do + fromForcedIdR <- fromForcedId str + fromNameR <- fromName str + fromIdR <- fromId str + return $ fromForcedIdR <|> fromNameR <|> fromIdR + where + fromName (EntityName . CI.mk -> name) = Bimap.lookupR name <$> use gEntityNames + fromId (preview entityId' -> Just n) = (n <$) . guard . Map.member n <$> use gEntities + fromId _ = return Nothing + fromForcedId ('#':str) = fromId str + fromForcedId _ = return Nothing instance Completion Faction GameState where completableLabel _ = "" -- cgit v1.2.3