1module Spell where 2 3import Control.Monad.State.Strict 4import qualified Data.Set as S 5import qualified Data.Map as M 6import qualified Data.CaseInsensitive as CI 7import qualified Data.Vector.Mutable as MV 8import Data.Char 9import Data.Maybe 10import Control.Monad.IfElse 11import UI.NCurses (Event(..)) 12import Control.Applicative 13import Prelude 14 15import Spell.Enum 16import CharMap 17import Types 18import Player 19import Time 20import World 21import Status 22import Unicode 23import Level.Border 24import Rand 25import DeepCopy 26import Invert 27 28type SpellAction = M NextStep -> M NextStep 29 30-- All spells in the game. Note though that the spells active in the world 31-- can change at run time; it's in the state. 32allSpells :: S.Set Spell 33allSpells = S.fromList 34 [ spell SpellWhiteout "Whiteout" (++ " will clear the way ahead") whiteOut 35 , spell SpellGenocide "Genocide Letter" (\i -> "Use " ++ i ++ " with care, it wipes the scroll bare!" ) genocide 36 , spell SpellWish "Wish" (++ " will give you any letter you wish" ) wish 37 ] `S.union` startingSpells `S.union` maybeStartingSpells 38 39-- Spells that the player starts off knowing. Both needed to get 40-- through the tutorial. 41startingSpells :: S.Set Spell 42startingSpells = S.fromList 43 [ spell SpellVomit "Vomit" (++ " helps when you've swallowed too many letters") vomit 44 , spell SpellNew "New" (++ "is a way to change what magic letters do") new 45 ] 46 47-- Spells that the player may start off knowing. (Less powerful.) 48maybeStartingSpells :: S.Set Spell 49maybeStartingSpells = S.fromList 50 [ spell SpellDream "Dream" (++ " lulls you away into dreamland" ) dream 51 , spell SpellReverse "Reverse" (++ "turns back to front") reversePlayer 52 , spell SpellBerzerk "Berzerk" (++ " makes you mad and strong") berzerk 53 ] 54 55invokeString :: String -> String 56invokeString ingredients = "\"" ++ map toUpper ingredients ++ "\"" 57 58spell :: SpellEnum -> SpellName -> (String -> String) -> (M NextStep -> M NextStep) -> Spell 59spell spellenum name hint = Spell name 60 (hint (invokeString ingredients)) 61 (S.fromList $ map CI.mk ingredients) 62 ingredients 63 where 64 ingredients = findingredients 0 "" 65 findingredients n s = case M.lookup (IngredientFor spellenum n) charUseMap of 66 Nothing 67 | null s -> error $ "Internal error: No ingredients defined for " ++ show spellenum 68 | otherwise -> reverse s 69 Just i -> findingredients (succ n) (i:s) 70 71vomit :: SpellAction 72vomit cont = do 73 showMessage "You cast a spell to clear your stomach." 74 p <- gets player 75 let l = catMaybes $ playerSwallowing p : (map segmentSwallowed (playerBody p)) 76 removeIngredients' (S.fromList $ map CI.mk l) 77 modifyPlayer $ removeSwallowing (const True) 78 writeWorld (getPos p) '*' 79 80 when (playerLen p > 4 && length (playerBody p) > 4 && length l >= 3) $ do 81 roll <- randM $ randomR (0, 15) 82 when (playerLen p > roll) $ do 83 modifyPlayer $ \pl -> pl 84 { playerLen = playerLen pl - 1 85 , playerBody = reverse (drop 1 (reverse (playerBody pl))) 86 } 87 showMessage "You feel queasy after vomiting up those letters.. You lose a tail segment." 88 cont 89 90new :: SpellAction 91new = promptingredient 92 where 93 promptingredient cont = do 94 swallowed <- mapMaybe segmentSwallowed . playerBody <$> gets player 95 if null swallowed 96 then noingredients cont 97 else prompt ("Pick the new spell's ingredient: [" ++ swallowed ++ "]") $ \i -> 98 case i of 99 (EventCharacter c) | (CI.mk c `elem` map CI.mk swallowed) -> do 100 removeIngredients' (S.singleton (CI.mk c)) 101 possibilities <- checkSpells (const True) <$> gets player 102 case possibilities of 103 [] -> noingredients cont 104 [s] -> do 105 addnewspell c s 106 cont 107 _ -> promptknownspell cont c 108 _ -> promptingredient cont 109 110 noingredients cont = do 111 showMessage "Failed to create new spell: You have no spell ingredients swallowed." 112 cont 113 114 promptknownspell cont ingredient = do 115 let retry = promptknownspell cont ingredient 116 prompt ("What spell should " ++ invokeString [ingredient] ++ " invoke?") $ \i -> 117 case i of 118 (EventCharacter c) -> do 119 p <- gets player 120 case toggleInvoke c p of 121 (InvokedChar, p') -> do 122 change p' 123 case checkInvokedSpells p' of 124 [] -> retry 125 l -> do 126 mapM_ (addnewspell ingredient) l 127 cont 128 (DeInvokedChar, p') -> do 129 change p' 130 retry 131 (NoInvoke, _) -> retry 132 _ -> retry 133 change p' = modifyPlayer (const p') 134 135 addnewspell ingredient basespell = do 136 let i = S.singleton (CI.mk ingredient) 137 let newspell = basespell { spellIngredients = i, spellWord = [ingredient] } 138 removeIngredients basespell 139 p <- gets player 140 change $ p { playerSpells = S.insert newspell (playerSpells p) } 141 showMessage $ "You can now cast " ++ spellName newspell ++ " using " ++ invokeString [ingredient] 142 143whiteOut :: SpellAction 144whiteOut cont = do 145 p <- gets player 146 writeWorld (playerHead p) ' ' 147 modifyPlayer $ removeSwallowing (const True) 148 case playerBody p of 149 (s:_) | segmentDirection s /= DDive -> 150 showeffect (\n -> "You cast Whiteout forward " ++ show n ++ " spaces") 151 =<< beam 152 (directionOffset $ segmentDirection s) 153 (playerHead p) 154 (beamlength p) 155 (0 :: Integer) 156 _ -> showeffect (const "You cast Whiteout all around your head.") 157 =<< around (playerHead p) 158 cont 159 where 160 showeffect _ 0 = showMessage "The Whiteout has no effect on the scroll's border." 161 showeffect msg n = showMessage (msg n) 162 163 beamlength :: Player -> Integer 164 beamlength p = ceiling (fromIntegral (playerLen p) / if playerEnergized p then 1 else 2 :: Double) 165 166 beam _ _ 0 n = return n 167 beam offset pos len n = do 168 let pos' = offsetPos offset pos 169 ok <- effect pos' 170 if ok 171 then beam offset pos' (len - 1) (n + 1) 172 else return n 173 174 around pos = length . filter id 175 <$> mapM (effect . (`offsetPos` pos)) (zip offs offs) 176 offs = [succ, pred, id] 177 178 effect pos@(_x,y) = do 179 maxy <- worldHeight 180 if y >= maxy 181 then return False 182 else do 183 c <- readWorld pos 184 if isBoundry c || y >= maxy 185 then return False 186 else do 187 writeWorld pos ' ' 188 return True 189 190genocide :: SpellAction 191genocide = promptletter 192 where 193 promptletter cont = prompt "Genocide which letter?" $ \i -> case i of 194 (EventCharacter c) 195 | isBoundry c || isSpace c -> do 196 showMessage "The spell fizzles and dies. Nice try." 197 cont 198 | otherwise -> removeall c cont 199 _ -> promptletter cont 200 201 removeall c cont = do 202 let toremove = CI.mk c 203 let removable = (== toremove) 204 p <- gets player 205 let playercharacters = '@' : map (bodyChar . segmentDirection) (playerBody p) 206 let selfgenocide = c `elem` playercharacters 207 energized <- playerEnergized <$> gets player 208 showMessage $ concat 209 [ "You genocided all " 210 , if energized then "" else "visible " 211 , if selfgenocide then [c] else unicodeCharString c ++ "'s!" 212 ] 213 -- remove from mouth 214 modifyPlayer $ removeSwallowing (removable . CI.mk) 215 -- remove swallowed 216 removeIngredients' (S.singleton toremove) 217 -- remove from world 218 removeworld c 219 when energized $ 220 removebuffer c 221 if selfgenocide 222 then do 223 showMessage "Sadly, that includes parts of you! You die.." 224 endThread 225 else cont 226 227 removeworld c = mapWorld $ \_ v -> return $ 228 if (v == c) 229 then Just ' ' 230 else Nothing 231 232 removebuffer c = do 233 b <- fst <$> gets bottomBuffer 234 let height = MV.length b 235 width <- worldWidth 236 let onb = \a -> lift (a b) 237 forM_ [0..height-1] $ \y -> 238 forM_ [0..width-1] $ \x -> do 239 v <- readS onb (x,y) 240 when (v == c) $ 241 writeS onb (x,y) ' ' 242 243dream :: SpellAction 244dream cont = do 245 -- Deep copy is needed because S contains mutable vectors, 246 -- and the dream would otherwise alter them. 247 st <- deepCopy =<< get 248 showMessage "You drift into a lucid dream..." 249 whenM (randM random) $ 250 modify $ \s -> s { peruser = nightmarespeed (peruser s) } 251 runDream cont cont (wakeupstate st) 252 where 253 -- In a nightmare, the scroll will seem to scroll faster. 254 nightmarespeed p@(Peruser { peruseSpeed = s } ) 255 | s > 2 = p { peruseSpeed = s - 1 } 256 | otherwise = p 257 wakeupstate origst dreamst = origst 258 -- Propigate random source to avoid identical 259 -- game play; this was not a precognitive dream. ;) 260 { randSource = randSource dreamst 261 -- Let the player learn new spells in the dream, 262 -- and use them upon awakening. 263 , spells = spells dreamst 264 -- If the player somehow didn't use help until in the 265 -- dream, propigate that state change too. 266 , helpShown = helpShown dreamst 267 } 268 269runDream :: M NextStep -> M NextStep -> (S -> S) -> M NextStep 270runDream sleepcont wakecont wakeupstate = go =<< sleepcont 271 where 272 go (NextStep v ms) = return $ NextStep v $ Just $ maybe wake (go <=<) ms 273 274 wake _evt = do 275 modify wakeupstate 276 showMessage $ "You wake from your dream, back where you were!" 277 wakecont 278 279berzerk :: SpellAction 280berzerk cont = do 281 showMessage "You fall into a mighty rage!" 282 modifyPlayer $ \p -> p { playerBerzerk = True } 283 p <- gets player 284 let len = playerLen p 285 duration <- randM $ randomR (len, len * 2) 286 let minduration = if playerEnergized p then 20 else 10 287 delayAction (min minduration duration) cont $ 288 -- Multiple berzerk spells can be in effect; 289 -- the first to expire expires them all. 290 whenM (playerBerzerk <$> gets player) $ do 291 showMessage "You stop seeing red.." 292 modifyPlayer $ \pl -> pl 293 { playerBerzerk = False 294 , playerEnergized = False 295 } 296 297reversePlayer :: SpellAction 298reversePlayer cont = do 299 p <- gets player 300 if null (playerBody p) 301 then fizzle 302 else if all (\s -> segmentSide s == CurrentSide) (playerBody p) 303 then do 304 modifyPlayer $ \_ -> invert p 305 success 306 else do 307 s <- get 308 let s' = flipOver s 309 put $ s' { player = invert (player s') } 310 success 311 where 312 fizzle = do 313 showMessage "The spell seems to do nothing much." 314 cont 315 success = do 316 showMessage "All of a sudden, you're going backwards!" 317 cont 318 319wish :: SpellAction 320wish cont = prompt ("What letter do you wish for?") $ \ev -> case ev of 321 (EventCharacter want) -> do 322 result <- if isSpace want 323 then do 324 roll <-randM $ randomR (1,10 :: Int) 325 if roll < 3 326 then return '|' 327 else return $ toUpper want 328 else return $ toUpper want 329 showMessage $ "A scattering of " ++ unicodeCharString result ++ "'s appear!" 330 width <- worldWidth 331 bodypos <- S.fromList <$> wormPositions 332 mapWorld $ \p@(x,_) c -> 333 if isSpace c || isBoundry c || p `S.member` bodypos 334 then return Nothing 335 else do 336 roll <- randM $ randomR (1,width) 337 return $ if roll == x 338 then Just result 339 else Nothing 340 cont 341 _ -> wish cont 342 343data ToggleInvokeResult 344 = InvokedChar 345 | DeInvokedChar 346 | NoInvoke 347 348toggleInvoke :: Char -> Player -> (ToggleInvokeResult, Player) 349toggleInvoke c p = case break matching (playerBody p) of 350 (_, []) -> (NoInvoke, p) 351 (presegs, s : postsegs) -> 352 let invoked = not (segmentInvoked s) 353 s' = s { segmentInvoked = invoked } 354 p' = p { playerBody = presegs ++ [s'] ++ postsegs } 355 result = if invoked then InvokedChar else DeInvokedChar 356 in (result, p') 357 where 358 ci = CI.mk c 359 matching s = case segmentSwallowed s of 360 Just sc | CI.mk sc == ci -> True 361 _ -> False 362 363-- It's possible for multiple spells to use the same ingredients. In this 364-- case, all matching spells are returned. 365checkInvokedSpells :: Player -> [Spell] 366checkInvokedSpells = checkSpells segmentInvoked 367 368checkSpells :: (Segment -> Bool) -> Player -> [Spell] 369checkSpells f p = S.toList matches 370 where 371 ingredients = S.fromList $ map CI.mk $ catMaybes $ 372 map avail $ playerBody p 373 avail s 374 | f s = segmentSwallowed s 375 | otherwise = Nothing 376 match sp = all (`S.member` ingredients) $ S.toList $ spellIngredients sp 377 matches = S.filter match (playerSpells p) 378 379removeIngredients :: Spell -> M () 380removeIngredients = removeIngredients' . spellIngredients 381 382-- Remove spell ingredients from the map and from being swallowed. 383removeIngredients' :: S.Set (CI.CI Char) -> M () 384removeIngredients' is = do 385 segs <- mapM go . playerBody =<< gets player 386 modifyPlayer $ \p -> p { playerBody = segs } 387 where 388 go seg = case segmentSwallowed seg of 389 Just c | S.member (CI.mk c) is -> do 390 case segmentSide seg of 391 CurrentSide -> writeWorld (getPos seg) ' ' 392 FlipSide -> writeFlipSide (getPos seg) ' ' 393 InSide -> return () 394 return $ seg 395 { segmentSwallowed = Nothing 396 , segmentInvoked = False 397 } 398 _ -> return seg 399 400-- Invokes all the listed spells, in order. 401invoke :: [Spell] -> M NextStep -> M NextStep 402invoke [] cont = cont 403invoke (s:rest) cont = do 404 isSpellCaster 405 removeIngredients s 406 spellAction s (invoke rest cont) 407 408teachRandomSpell :: Player -> M Player 409teachRandomSpell p = do 410 let known = playerSpells p 411 avail <- gets spells 412 let unknown = S.difference avail known 413 if S.null unknown 414 then do 415 showMessage "You wrack your brain, but any more spells, you'll have to learn." 416 return p 417 else go unknown 418 where 419 go set = do 420 s <- randFrom (S.toList set) 421 showMessage $ "You remember a spell: " ++ spellHint s 422 return $ p { playerSpells = S.insert s (playerSpells p) } 423 424spellInventory :: M [String] 425spellInventory = header . map fmt . S.toList . playerSpells <$> gets player 426 where 427 header l = " Spell Inventory" : "" : l 428 fmt s = concat 429 [ " " 430 , pad maxspellname $ spellName s 431 , pad 6 $ invokeString $ spellWord s 432 ] 433 pad n s = s ++ (replicate (1 + n - length s) ' ') 434 maxspellname = maximum $ map (length . spellName) (S.toList allSpells) 435