archetypes & cleanup

5 files changed, 172 insertions, 20 deletions

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 (‘#<n>’)"
+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 _ = "<archetype>"
+  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 _ = "<entity>"
   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 _ = "<faction>"