1module Control where 2 3import Control.Monad.State.Strict 4import UI.NCurses (Event(..), Key(..)) 5import qualified Data.Map as M 6import Data.Maybe 7import Control.Applicative 8import Prelude 9 10import Types 11import Status 12import Time 13import Player 14import Player.Move 15import Peruser 16import Spell 17import CharMap 18import Poison 19import Help 20import View 21import Curses 22 23mainLoop :: Step 24mainLoop (EventCharacter '\t') = forceRedraw 25mainLoop (EventCharacter c) = case M.lookup c charMap of 26 Just (CharControl (Movement d)) -> move d 27 Just (CharControl Inventory) -> inventory 28 Just (CharControl Help) -> showHelp 29 Just (CharControl Quit) -> checkQuit 30 Just (CharControl Wait) -> wait 31 Just (IngredientFor _ _) -> invokeSwallowed c 32 Just (Poison _) -> ignore 33 Nothing -> invokeSwallowed c 34mainLoop e = maybe ignore move (arrowDirection e) 35 36-- Does not step time 37ignore :: M NextStep 38ignore = next mainLoop 39 40-- Does step time 41continue :: M NextStep 42continue = runPeruser =<< next mainLoop 43 44wait :: M NextStep 45wait = continue 46 47showHelp :: M NextStep 48showHelp = do 49 modify $ \s -> s { helpShown = True } 50 helpWindow 51 next $ \_ -> clearWindows >> ignore 52 53diveIn :: M NextStep 54diveIn = go =<< diveThrough 55 where 56 go False = ignore 57 go True = do 58 modify $ \s -> s { helpShown = True } 59 continue 60 61move :: Direction -> M NextStep 62move DDive = diveIn 63move d = go =<< checkedMove =<< supportStaggaring d 64 where 65 go CannotMove = ignore 66 go EscapedScroll = escapedScroll 67 go (SuccessfulMove a) = a continue 68 go SuccessfulBacktrack = continue 69 go TooFullToMove = do 70 n <- length . mapMaybe segmentSwallowed . playerBody <$> gets player 71 showMessage $ concat 72 [ "You've swallowed " 73 , if n > 1 then "some letters" else "a letter" 74 , ", and cannot drag " 75 , if n > 1 then "them" else "it" 76 , " along." 77 ] 78 ignore 79 80invokeSwallowed :: Char -> M NextStep 81invokeSwallowed c = do 82 p <- gets player 83 case toggleInvoke c p of 84 (InvokedChar, p') -> do 85 change p' 86 case checkInvokedSpells p' of 87 [] -> continue 88 l -> invoke l continue 89 (DeInvokedChar, p') -> do 90 change p' 91 continue 92 (NoInvoke, _) -> ignore 93 where 94 change p' = modifyPlayer (const p') 95 96inventory :: M NextStep 97inventory = do 98 showWindow (3, 0) =<< spellInventory 99 next $ \_ -> clearWindows >> ignore 100 101checkQuit :: M NextStep 102checkQuit = prompt "Are you sure you want to quit? [yn]" $ \i -> case i of 103 EventCharacter 'y' -> do 104 showMessage "Bye!" 105 endThread 106 _ -> do 107 clearMessage 108 ignore 109 110forceRedraw :: M NextStep 111forceRedraw = do 112 view <- lift . mkView =<< get 113 let view' = view { viewForceRedraw = True } 114 return $ NextStep view' (Just mainLoop) 115 116escapedScroll :: M NextStep 117escapedScroll = do 118 showMessage "You escaped the scroll! You win!" 119 next $ victorydance (30 :: Int) 120 where 121 victorydance 0 _ = endThread 122 victorydance n e = do 123 let dir = case e of 124 (EventCharacter c) -> case M.lookup c charMap of 125 Just (CharControl (Movement d)) 126 | d /= DUp && d /= DDive -> d 127 _ -> DDown 128 (EventSpecialKey KeyLeftArrow) -> DLeft 129 (EventSpecialKey KeyRightArrow) -> DRight 130 _ -> DDown 131 moveaway DDown 132 when (dir /= DDown) $ 133 moveaway dir 134 next $ victorydance (n-1) 135 136 moveaway dir = do 137 hpos <- getPos <$> gets player 138 let seg = Segment hpos dir CurrentSide Nothing False 139 setHeadPos $ directionOffset dir `offsetPos` hpos 140 modifyPlayer $ \p -> p { playerBody = shiftBody p seg } 141