1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings, OverloadedLists, RankNTypes #-}
module Sequence.Utils
( withArg, withFocus, withFocus'
, focusState
, toName, toDesc
, outputLogged
, Argument(..)
, Completion(..)
, module Sequence.Utils.Ask
) where
import Sequence.Types
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Control.Applicative
import Control.Monad
import Control.Lens
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Function
import Data.Default
import Data.Maybe
import Text.Read (readMaybe)
import Data.List
import Data.Bool
import Data.Char
import System.Console.Shell
import System.Console.Shell.ShellMonad
import System.Console.Shell.Backend.Haskeline
import Sequence.Utils.Ask
import Sequence.Contact.Types
import Sequence.Formula
import Text.Regex (mkRegex, subRegex)
class Argument a st | a -> st where
arg :: String -> Sh st (Maybe a)
withArg :: Argument a st => (a -> Sh st ()) -> (Completable a -> Sh st ())
withArg f (Completable str) = arg str >>= \a -> case a of
Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’"
Just a -> f a
withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState ()
withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f
withFocus' :: (Entity -> Sh GameState a) -> Sh GameState (Maybe a)
withFocus' f = preuse gFocus' >>= maybe (Nothing <$ shellPutErrLn "Currently not focusing any entity") (fmap Just . f)
focusState :: MonadState s m => Traversal' s a -> StateT a (MaybeT m) b -> m (Maybe b)
focusState lens action = runMaybeT $ uncurry (<$) . over _2 (lens .=) =<< runStateT action =<< MaybeT (preuse lens)
unaligned = view faction' def
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
toDesc :: (MonadState GameState m, MonadIO m) => EntityIdentifier -> m String
toDesc ident = do
name <- toName ident
health <- runMaybeT $ do
maxVit <- MaybeT . focusState (gEntities . ix ident) . evalFormula' [name] =<< (MaybeT . preuse $ gEntities . ix ident . eStats . sMaxVitality)
hDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sTotalDamage
fDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sFatigue
return $ (maxVit - hDamage, maxVit - fDamage)
case health of
Just dmg -> return $ name ++ " " ++ show dmg
Nothing -> return name
outputLogged :: EntityIdentifier -> String -> Sh GameState ()
outputLogged id str = gLog <>= pure (id, clean str) >> shellPutStrLn str
where
clean str = subRegex (mkRegex "(\x9B|\x1B\\[)[0-?]*[ -/]*[@-~]") str "" -- remove ANSI escapes
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 = \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>"
complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . nub . sort $ unaligned : map (view faction') (st ^. inhabitedFactions)
instance Argument Faction GameState where
arg = return . Just . flip (set faction') def
instance Completion (Set Hitzone) GameState where
completableLabel _ = "<hitzones>"
complete _ st (over each reverse . span (/= ',') . reverse -> (wPrefix, lPrefix))
| not $ null wPrefix
, all (== '*') wPrefix = return . pure . join $ hitzones
| otherwise = return . map (lPrefix ++) . filter ((isPrefixOf `on` CI.foldCase) wPrefix) $ hitzones
where
hitzones = sort . map (review hitzone) $ fromMaybe [] (Map.keys <$> preview (gFocus' . eStats . sHitzones) st)
join [] = ""
join [x] = x
join (x:xs) = x ++ "," ++ join xs
instance Argument (Set Hitzone) GameState where
arg protoWs = runMaybeT $ do
let
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
split = foldr (\c l@(w:ws) -> if c == ',' then "" : l else (c : w) : ws) [""]
ws = Set.fromList . map CI.mk . filter (not . null) . map trim . split $ protoWs
hasGlob = Set.member "*" ws
hitzones <- Set.map (view _Hitzone) . Map.keysSet <$> MaybeT (preuse $ gFocus' . eStats . sHitzones)
guard (hasGlob || ws `Set.isSubsetOf` hitzones)
return . Set.map (review _Hitzone) $ if hasGlob then hitzones else ws
instance Completion DamageType GameState where
completableLabel _ = "<damageType>"
complete _ _ prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) $ map show ([minBound .. maxBound] :: [DamageType])
instance Argument DamageType GameState where
arg (CI.mk -> word) = return $ Map.lookup word types
where
types = Map.fromList [(CI.mk $ show dType, dType) | dType <- [minBound .. maxBound]]
instance Completion (Formula Stats) GameState where
completableLabel _ = "<value>"
complete _ st (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys $ Map.filter (isJust . (\a -> preview (gFocus' . eStats . folding a) st)) statAccessors
instance Argument (Formula Stats) GameState where
arg (CI.mk -> name) = runMaybeT $ do
accessor <- MaybeT . return $ Map.lookup name statAccessors
MaybeT . preuse $ gFocus' . eStats . folding accessor
statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats))
statAccessors = [ ("Stärke", preview sAStrength)
, ("Ausdauer", preview sAEndurance)
, ("Masse", preview sAMass)
, ("Reflexe", preview sAReflexes)
, ("Beweglichkeit", preview sAMobility)
, ("Geschicklichkeit", preview sADexterity)
, ("Intelligenz", preview sAIntelligence)
, ("Charisma", preview sACharisma)
, ("Wahrnehmung", preview sAPerception)
, ("Entschlossenheit", preview sAWillpower)
, ("Archaische Distanzwaffen", preview sSArchaicRanged)
, ("Handfeuerwaffen", preview sSFirearms)
, ("Schwere Waffen", preview sSHeavyWeapons)
, ("Energiewaffen", preview sSEnergyWeapons)
, ("Waffenloser Nahkampf", preview sSUnarmedMelee)
, ("Bewaffneter Nahkampf", preview sSArmedMelee)
, ("Wurfwaffen", preview sSThrownWeapons)
, ("Tarnung & Schleichen", preview sSStealth)
, ("Diebeshandwerk & Betrügerei", preview sSThievery)
, ("Schlösser Knacken", preview sSLockpicking)
, ("Fallen Stellen & Entschärfen", preview sSTrapping)
, ("Naturwissenschaften", preview sSSciences)
, ("Erste Hilfe", preview sSFirstAid)
, ("Medizinische Praktik", preview sSMedicine)
, ("Geisteswissenschaften", preview sSHumanities)
, ("Ingenieurwesen & Reperatur", preview sSEngineering)
, ("Handwerkskunst", preview sSCraft)
, ("Interface", preview sSInterface)
, ("Redekunst", preview sSSpeech)
, ("Führung", preview sSLeadership)
, ("Hauswirtschaft", preview sSHomeEconomics)
, ("Überlebenskunst", preview sSSurvival)
, ("Motorrad", preview sSMotorcycle)
, ("Radfahrzeug", preview sSWheeled)
, ("Schwebefahrzeug", preview sSHovercraft)
, ("Tragflächenmaschine", preview sSAircraft)
, ("Raumfahrzeug", preview sSSpacecraft)
, ("Wasserfahrzeug", preview sSWatercraft)
, ("Kettenfahrzeug", preview sSTracked)
, ("Exoskelett", preview sSExoskeleton)
, ("Beißen", preview sSBiting)
, ("Aufspüren", preview sSSearching)
, ("Betragen", preview sSDemeanour)
, ("Rammen", preview sSRamming)
, ("Zielerfassung", preview sSTargeting)
, ("Verständnis", preview sSComprehension)
, ("Maximale Vitalität", preview sMaxVitality)
, ("Sequenzwert", preview sSeqVal)
, ("Schmerztoleranz", preview sPainTolerance)
, ("Erschöpfungstoleranz", preview sFatigueTolerance)
, ("Vitalität", liftM2 (-) <$> preview sMaxVitality <*> preview (sTotalDamage . to return))
, ("Erschöpfung", preview $ sFatigue . to return)
]
|
