diff --git a/MazesOfMonad.cabal b/MazesOfMonad.cabal --- a/MazesOfMonad.cabal +++ b/MazesOfMonad.cabal @@ -1,5 +1,5 @@ Name: MazesOfMonad -Version: 1.0.6 +Version: 1.0.7 Description: MazesOfMonad is a console-based Role Playing Game. You create characters with their strong and weak points, and try to complete mazes that are randomly generated. You can pick up gold and items on the way, meet monsters, and deal with them as you want. You can fight, use magic, bribe, trade, steal... This is only a simple game that I did to see what building a @@ -11,25 +11,25 @@ Maintainer: jpmoresmau@gmail.com Synopsis: Console-based Role Playing Game Build-Type: Simple -Build-Depends: base < 5 , HUnit, random, - regex-posix, containers, filepath, directory, pretty, - array, mtl, old-locale, time -tested-with: GHC==6.10.1, GHC==6.12.1 +tested-with: GHC==7.0.2 data-files: README.txt, WHATSNEW.txt, TODO.txt +cabal-version: >= 1.2 -Executable: mazesofmonad -Main-is: Main.hs -extensions: FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving -hs-source-dirs: src -include-dirs: src/ -other-modules: MoresmauJP.Core.Screen, MoresmauJP.Maze1.Maze,MoresmauJP.Maze1.MazeGame - ,MoresmauJP.Rpg.Actions,MoresmauJP.Rpg.ActionsTests,MoresmauJP.Rpg.Arena,MoresmauJP.Rpg.ArenaTests - ,MoresmauJP.Rpg.Character,MoresmauJP.Rpg.CharacterTests,MoresmauJP.Rpg.Fight,MoresmauJP.Rpg.FightTests - ,MoresmauJP.Rpg.Inventory,MoresmauJP.Rpg.InventoryTests,MoresmauJP.Rpg.Items,MoresmauJP.Rpg.ItemsTests - ,MoresmauJP.Rpg.Magic,MoresmauJP.Rpg.MagicTests,MoresmauJP.Rpg.MazeObjects,MoresmauJP.Rpg.MazeObjectsTests - ,MoresmauJP.Rpg.NPC,MoresmauJP.Rpg.NPCTests,MoresmauJP.Rpg.Profile,MoresmauJP.Rpg.ProfileTests - ,MoresmauJP.Rpg.RPG,MoresmauJP.Rpg.Save,MoresmauJP.Rpg.SaveTests,MoresmauJP.Rpg.Stats,MoresmauJP.Rpg.TextOutput - ,MoresmauJP.Rpg.Trade,MoresmauJP.Rpg.TradeTests - ,MoresmauJP.Util.Lists,MoresmauJP.Util.ListsTests,MoresmauJP.Util.Numbers,MoresmauJP.Util.NumbersTests - ,MoresmauJP.Util.Random,MoresmauJP.Util.RandomTests - +Executable mazesofmonad + Main-is: Main.hs + extensions: FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving + hs-source-dirs: src + include-dirs: src/ + other-modules: MoresmauJP.Core.Screen, MoresmauJP.Maze1.Maze,MoresmauJP.Maze1.MazeGame + ,MoresmauJP.Rpg.Actions,MoresmauJP.Rpg.ActionsTests,MoresmauJP.Rpg.Arena,MoresmauJP.Rpg.ArenaTests + ,MoresmauJP.Rpg.Character,MoresmauJP.Rpg.CharacterTests,MoresmauJP.Rpg.Fight,MoresmauJP.Rpg.FightTests + ,MoresmauJP.Rpg.Inventory,MoresmauJP.Rpg.InventoryTests,MoresmauJP.Rpg.Items,MoresmauJP.Rpg.ItemsTests + ,MoresmauJP.Rpg.Magic,MoresmauJP.Rpg.MagicTests,MoresmauJP.Rpg.MazeObjects,MoresmauJP.Rpg.MazeObjectsTests + ,MoresmauJP.Rpg.NPC,MoresmauJP.Rpg.NPCTests,MoresmauJP.Rpg.Profile,MoresmauJP.Rpg.ProfileTests + ,MoresmauJP.Rpg.RPG,MoresmauJP.Rpg.Save,MoresmauJP.Rpg.SaveTests,MoresmauJP.Rpg.Stats,MoresmauJP.Rpg.TextOutput + ,MoresmauJP.Rpg.Trade,MoresmauJP.Rpg.TradeTests + ,MoresmauJP.Util.Lists,MoresmauJP.Util.ListsTests,MoresmauJP.Util.Numbers,MoresmauJP.Util.NumbersTests + ,MoresmauJP.Util.Random,MoresmauJP.Util.RandomTests + Build-Depends: base < 5 , HUnit, random, + regex-posix, containers, filepath, directory, pretty, + array, mtl, old-locale, time diff --git a/src/MoresmauJP/Core/Screen.hs b/src/MoresmauJP/Core/Screen.hs --- a/src/MoresmauJP/Core/Screen.hs +++ b/src/MoresmauJP/Core/Screen.hs @@ -13,15 +13,15 @@ -- | a Screen represent a certain UI state, with possible actions data Screen a = Screen { - actions::[Action a] -- ^ possible action in that screen - } + actions::[Action a] -- ^ possible action in that screen + } -- | Action doable in the ui data Action a = Action { - actionName::String -- ^ the name of the action (what to type) - , actionDescription::String -- ^ the description (showed when using help) - , actionFunction::(ActionFunction a) -- ^ the function to call - } + actionName::String -- ^ the name of the action (what to type) + , actionDescription::String -- ^ the description (showed when using help) + , actionFunction::(ActionFunction a) -- ^ the function to call + } -- | a Monad transformer, wrapping state (a), IO and Random type ScreenT a b= (RandT (StateT a IO)) b @@ -35,7 +35,7 @@ -- | add a ScreenMessage to the current messages addScreenMessage :: (MonadWriter ScreenMessages m,Monad m)=> ScreenMessage -> m () addScreenMessage msg=tell [msg] - + -- | A Monad Transformer, ScreenT with GameState and returning Widgets type GSWScreenT a= ScreenT (GameState a) (Widget a) @@ -44,8 +44,8 @@ type WScreenT a=WriterT ScreenMessages (RandT (StateT (GameState a) IO)) (Widget a) instance (Monad m) => MonadRandom (WriterT ScreenMessages (RandT m)) where - getRandomRange =lift . getRandomRange - getSplit = lift getSplit + getRandomRange =lift . getRandomRange + getSplit = lift getSplit -- | An Action function get its arguments typed in the GUI and works in a WScreenT @@ -53,189 +53,189 @@ -- | GameState: the data (a) and the current screen data GameState a = GameState {gsData::a -- ^ the data - , screen::Maybe (Screen a) -- ^ the current screen - } + , screen::Maybe (Screen a) -- ^ the current screen + } -- | Widgets are the actual ui component returned by an action data Widget a= - -- | simple line of text - WText { - wtext::String -- ^ line of text - } - -- | list of items - | WList {witems :: [String] -- ^ lines of text - } - -- | ask for the user to type in a string - | WInput { - witems :: [String] -- ^ lines of text - , wact::(String -> WScreenT a) -- ^ handler action - } - -- | choose an item from a list - | WCombo { - witems :: [String] -- ^ lines of text - ,wlist :: [String] -- ^ list items - ,wact :: (String -> WScreenT a) -- ^ handler action - } - -- | asks a yes/no question - | WCheck { - witems :: [String] -- ^ lines of text - ,wquestion :: String -- ^ question - ,wdefault :: Bool -- ^ default answer - ,wbact :: (Bool -> WScreenT a) -- ^ handler action - } - -- | placeholder for no action - | WNothing + -- | simple line of text + WText { + wtext::String -- ^ line of text + } + -- | list of items + | WList {witems :: [String] -- ^ lines of text + } + -- | ask for the user to type in a string + | WInput { + witems :: [String] -- ^ lines of text + , wact::(String -> WScreenT a) -- ^ handler action + } + -- | choose an item from a list + | WCombo { + witems :: [String] -- ^ lines of text + ,wlist :: [String] -- ^ list items + ,wact :: (String -> WScreenT a) -- ^ handler action + } + -- | asks a yes/no question + | WCheck { + witems :: [String] -- ^ lines of text + ,wquestion :: String -- ^ question + ,wdefault :: Bool -- ^ default answer + ,wbact :: (Bool -> WScreenT a) -- ^ handler action + } + -- | placeholder for no action + | WNothing -- | a widget and a gamestate type ScreenState a = (Widget a,GameState a) -- | get a Combo widget that uses the show method of the objects passed to automatically build the list getShowCombo :: Show b => [String] -- ^ lines of text - -> [b] -- ^ objects to display in list - -> ((ComboResult b) -> WScreenT a) -- ^ handler action (gets the selected object as parameter - -> Widget a -- ^ the resulting widget + -> [b] -- ^ objects to display in list + -> ((ComboResult b) -> WScreenT a) -- ^ handler action (gets the selected object as parameter + -> Widget a -- ^ the resulting widget getShowCombo= getMappedCombo show -- | get a Combo widget that uses an arbitrary method of the objects passed to automatically build the list getMappedCombo :: (b-> String) -- ^ the method to use to translate the object in a string from the menu - -> [String] -- ^ lines of text - -> [b] -- ^ objects to display in list - -> ((ComboResult b) -> WScreenT a) -- ^ handler action (gets the selected object as parameter - -> Widget a -- ^ the resulting widget + -> [String] -- ^ lines of text + -> [b] -- ^ objects to display in list + -> ((ComboResult b) -> WScreenT a) -- ^ handler action (gets the selected object as parameter + -> Widget a -- ^ the resulting widget getMappedCombo myShow s objs af= - let - objWithNames=map (\x-> (x,myShow x)) objs - af2=(\s2 -> do - if null s2 - then - af Empty - else - do - let objChosen=listToMaybe (map fst (filter (\x-> (snd x) == s2) objWithNames)) - case objChosen of - Just oc-> af (Exact oc) - Nothing-> af (Unknown s2) - ) - in (WCombo s (map snd objWithNames) af2) - + let + objWithNames=map (\x-> (x,myShow x)) objs + af2=(\s2 -> do + if null s2 + then + af Empty + else + do + let objChosen=listToMaybe (map fst (filter (\x-> (snd x) == s2) objWithNames)) + case objChosen of + Just oc-> af (Exact oc) + Nothing-> af (Unknown s2) + ) + in (WCombo s (map snd objWithNames) af2) + -- | checks if the rest of the command line is already an option from the menu getPretypedWidget :: Widget a -- ^ the original widget - -> [String] -- ^ the rest of the parameters typed by the user - -> WScreenT a -- ^ the result + -> [String] -- ^ the rest of the parameters typed by the user + -> WScreenT a -- ^ the result getPretypedWidget wc@(WCombo _ choices af) (typed:_) = do - -- see if the next parameter is a number corresponding to one of the items in the list - let chosen=filter (\(x,_)-> x==typed) (zipWith (\a b -> ((show a),b)) [1..] choices) - if (null chosen) - then return wc - -- we have a match, run the action - else af (snd $ head chosen) + -- see if the next parameter is a number corresponding to one of the items in the list + let chosen=filter (\(x,_)-> x==typed) (zipWith (\a b -> ((show a),b)) [1..] choices) + if (null chosen) + then return wc + -- we have a match, run the action + else af (snd $ head chosen) getPretypedWidget w _=return w - + removeWithName :: [Action a] -> [Action b] -> [Action a] removeWithName aa ab= - let names=(map actionName aa) \\ (map actionName ab) - in filter (\a -> elem (actionName a) names) aa + let names=(map actionName aa) \\ (map actionName ab) + in filter (\a -> elem (actionName a) names) aa -- | result from a user action data ComboResult a= Empty -- ^ no result, nothing chosen - | Unknown String -- ^ unknown result (typed something not in a list) - | Exact a -- ^ proper choice - deriving (Show,Read) - + | Unknown String -- ^ unknown result (typed something not in a list) + | Exact a -- ^ proper choice + deriving (Show,Read) + -- | start a UI loop start :: ScreenState a -- ^ initial state - -> IO(a) -- ^ result + -> IO(a) -- ^ result start (w,gs)=do - GameState s2 _ <- ioRandT (commandLoop2 w) gs - return s2 - + GameState s2 _ <- ioRandT (commandLoop2 w) gs + return s2 + -- | internal UI loop commandLoop2 :: Widget a -- ^ current widget to render - -> GSWScreenT a -- ^ screen monad we run in + -> GSWScreenT a -- ^ screen monad we run in commandLoop2 w = do - af<- liftIO $ renderWidget w - scr <- gets screen - if (isJust scr) - then - if isJust af - then - do - (w2,msgs) <- runWriterT $ fromJust af - when (not $ null msgs) (liftIO $ (mapM_ putStrLn msgs)) - commandLoop2 w2 - else - do - liftIO $ putStr ">" - input <- liftIO $ getLine - let cmds = words input - if null cmds - then - commandLoop2 WNothing - else - do - let (cmd:_)=cmds - let af2 = getAction (map Data.Char.toLower cmd) (actions $ fromJust scr) - (w2,msgs)<- runWriterT (af2 cmds) - when (not $ null msgs) (liftIO $ (mapM_ putStrLn msgs)) - commandLoop2 w2 - else - return WNothing + af<- liftIO $ renderWidget w + scr <- gets screen + if (isJust scr) + then + if isJust af + then + do + (w2,msgs) <- runWriterT $ fromJust af + when (not $ null msgs) (liftIO $ (mapM_ putStrLn msgs)) + commandLoop2 w2 + else + do + liftIO $ putStr ">" + input <- liftIO $ getLine + let cmds = words input + if null cmds + then + commandLoop2 WNothing + else + do + let (cmd:_)=cmds + let af2 = getAction (map Data.Char.toLower cmd) (actions $ fromJust scr) + (w2,msgs)<- runWriterT (af2 cmds) + when (not $ null msgs) (liftIO $ (mapM_ putStrLn msgs)) + commandLoop2 w2 + else + return WNothing -- | render a widget onto the console -renderWidget :: Widget a -- ^ the widget to render - -> IO(Maybe(WScreenT a)) -- ^ the result (may be empty) +renderWidget :: Widget a -- ^ the widget to render + -> IO(Maybe(WScreenT a)) -- ^ the result (may be empty) renderWidget (WNothing)= do - return Nothing + return Nothing renderWidget (WText s)= do - putStrLn s - return Nothing + putStrLn s + return Nothing renderWidget (WList ss)=do - mapM_ putStrLn ss - return Nothing + mapM_ putStrLn ss + return Nothing renderWidget (WInput ss1 af)=do - mapM_ putStrLn ss1 - input <- getLine - return (Just $ af input) + mapM_ putStrLn ss1 + input <- getLine + return (Just $ af input) renderWidget (WCheck ss1 s def af)=do - mapM_ putStrLn ss1 - let choices=if def then " (Y/n)" else " (y/N)" - putStrLn (s ++choices) - cmds <- getArgs - let ch=if null cmds - then def - else (map toUpper (head cmds))=="Y" - return (Just (af ch)) + mapM_ putStrLn ss1 + let choices=if def then " (Y/n)" else " (y/N)" + putStrLn (s ++choices) + cmds <- getArgs + let ch=if null cmds + then def + else (map toUpper (head cmds))=="Y" + return (Just (af ch)) renderWidget (WCombo ss1 ss2 af)=do - mapM_ putStrLn ss1 - let choices=zipWith (\a b -> ((show a),b)) [1..] ss2 - mapM_ putStrLn (map (\(a,b) -> a ++ ": "++b) choices) - cmds <- getArgs - let chosen=if null cmds - then [("","")] - else filter (\(x,_)-> x==(head cmds)) choices - if null chosen - then return (Just $ af "") - else return (Just $ af (snd $ head chosen)) - --- | get arguments typed in at the command line -getArgs :: IO([String]) -- ^ the resulting arguments + mapM_ putStrLn ss1 + let choices=zipWith (\a b -> ((show a),b)) [1..] ss2 + mapM_ putStrLn (map (\(a,b) -> a ++ ": "++b) choices) + cmds <- getArgs + let chosen=if null cmds + then [("","")] + else filter (\(x,_)-> x==(head cmds)) choices + if null chosen + then return (Just $ af "") + else return (Just $ af (snd $ head chosen)) + +-- | get arguments typed in at the command line +getArgs :: IO([String]) -- ^ the resulting arguments getArgs = do - input <- getLine - return (words input) + input <- getLine + return (words input) --- | show help with available commands +-- | show help with available commands help :: Bool -- ^ display help on system commands too? - -> ActionFunction a -- ^ the handler function + -> ActionFunction a -- ^ the handler function help withSystem _ = do - let f (Action s1 s2 _)= (s1++": "++s2) - let sysLines= if withSystem - then (map f systemActions) - else [] - gs <- get - let acts=actions $ fromJust $ screen gs - let wl=WList (sort ( sysLines ++ - (map f acts))) - return (wl) + let f (Action s1 s2 _)= (s1++": "++s2) + let sysLines= if withSystem + then (map f systemActions) + else [] + gs <- get + let acts=actions $ fromJust $ screen gs + let wl=WList (sort ( sysLines ++ + (map f acts))) + return (wl) -- | default handler for unknown actions unknown :: ActionFunction a @@ -244,62 +244,62 @@ -- | quit the game action quit :: ActionFunction a quit _ = do - modify (\gs-> gs{screen=Nothing}) - return (WText ("Bye bye, hope you enjoyed the game!")) + modify (\gs-> gs{screen=Nothing}) + return (WText ("Bye bye, hope you enjoyed the game!")) -- | when several actions could fit what the user typed, display the list of full names choice :: [String] -- ^ possible actions - -> ActionFunction a -- ^ resulting handler + -> ActionFunction a -- ^ resulting handler choice ss _ = return (WList ss) -- | back action backAction :: Screen a -- ^ Screen to go back to - -> Action a -- ^ resulting action + -> Action a -- ^ resulting action backAction sc=Action "back" "Go back to main screen" (back sc) -- | back handler back :: Screen a -- ^ Screen to go back to - -> ActionFunction a -- ^ result + -> ActionFunction a -- ^ result back sc _ =do - (GameState a _) <- get - put (GameState a (Just sc)) - return (WText "Back") + (GameState a _) <- get + put (GameState a (Just sc)) + return (WText "Back") -- | default system actions systemActions :: [Action a] systemActions = [Action "help" "Provides help on available actions" (help True) - ,Action "?" "Provides help on available actions" (help True) - ,Action "quit" "Exit the game" quit] - + ,Action "?" "Provides help on available actions" (help True) + ,Action "quit" "Exit the game" quit] + -- | get action from what the user typed and the possible actions getAction :: String -- ^ the first word the user typed - -> [Action a] -- ^ the possible actions - -> ActionFunction a -- ^ the chosen action handler + -> [Action a] -- ^ the possible actions + -> ActionFunction a -- ^ the chosen action handler getAction "help" _ = help True getAction cmd acts = - let - filt=(filter (\x-> isPrefixOf cmd (map Data.Char.toLower (actionName x)))) - possible=(filt systemActions) ++ (filt acts) - l = length possible - in - if l==0 then - unknown - else if l==1 then - actionFunction $ head possible - else - choice (map (\(Action s1 _ _)-> s1) possible) + let + filt=(filter (\x-> isPrefixOf cmd (map Data.Char.toLower (actionName x)))) + possible=(filt systemActions) ++ (filt acts) + l = length possible + in + if l==0 then + unknown + else if l==1 then + actionFunction $ head possible + else + choice (map (\(Action s1 _ _)-> s1) possible) -- | combine a widget with maybe another combineMaybeWidget :: Widget a -- ^ initial widget - -> Maybe (Widget a) -- ^ next widget - -> Widget a -- ^ resulting widget + -> Maybe (Widget a) -- ^ next widget + -> Widget a -- ^ resulting widget combineMaybeWidget w Nothing = w combineMaybeWidget w1 (Just w2) =combineWidget w1 w2 - --- | combine a widget with another + +-- | combine a widget with another combineWidget :: Widget a -- ^ initial widget - -> Widget a -- ^ next widget - -> Widget a -- ^ resulting widget + -> Widget a -- ^ next widget + -> Widget a -- ^ resulting widget combineWidget WNothing a=a combineWidget a WNothing=a combineWidget (WText s1) (WText s2)=WList [s1,s2] diff --git a/src/MoresmauJP/Maze1/Maze.hs b/src/MoresmauJP/Maze1/Maze.hs --- a/src/MoresmauJP/Maze1/Maze.hs +++ b/src/MoresmauJP/Maze1/Maze.hs @@ -3,13 +3,15 @@ module MoresmauJP.Maze1.Maze where +import MoresmauJP.Util.Lists import MoresmauJP.Util.Random + import Data.List import qualified Data.Map as DataMap import qualified Data.Set as DataSet import Data.Maybe -import MoresmauJP.Util.Lists + data GameWorld = GameWorld { maze::Maze diff --git a/src/MoresmauJP/Rpg/Inventory.hs b/src/MoresmauJP/Rpg/Inventory.hs --- a/src/MoresmauJP/Rpg/Inventory.hs +++ b/src/MoresmauJP/Rpg/Inventory.hs @@ -1,73 +1,73 @@ -- | Inventory management -- (c) JP Moresmau 2009 module MoresmauJP.Rpg.Inventory ( - Inventory(), Position(..), ItemType(..), InventoryError(..),PotionType(..), - makeEmptyInventory, makeFullInventory, takeItem, dropItem, listItems, - listAllowedPositions,listActiveItems,listCarriedItems,listCarriedItemsUniqueObject, - getCarriedItem, positionAllowed, addGold, getGold, - Gold, isActive - ) where + Inventory(), Position(..), ItemType(..), InventoryError(..),PotionType(..), + makeEmptyInventory, makeFullInventory, takeItem, dropItem, listItems, + listAllowedPositions,listActiveItems,listCarriedItems,listCarriedItemsUniqueObject, + getCarriedItem, positionAllowed, addGold, getGold, + Gold, isActive + ) where import Data.List import Data.Maybe import qualified Data.Map as M data ItemType = Weapon { - itName::String, - damageLow::Int, - damageHigh::Int, - hands::Int, - price::Gold} - | Armor { - itName::String, - damageLow::Int, - damageHigh::Int, - price::Gold} - | Shield { - itName::String, - damageLow::Int, - damageHigh::Int, - price::Gold} - | Helmet { - itName::String, - damageLow::Int, - damageHigh::Int, - price::Gold} - | Potion { - itName::String, - potionType::PotionType, - price::Gold} - | Scroll { - itName::String, - spellType::String, - price::Gold} - | Trap { - itName::String, - damageLow::Int, - damageHigh::Int, - triggerDescription::String - } - deriving (Show,Read,Eq) - + itName::String, + damageLow::Int, + damageHigh::Int, + hands::Int, + price::Gold} + | Armor { + itName::String, + damageLow::Int, + damageHigh::Int, + price::Gold} + | Shield { + itName::String, + damageLow::Int, + damageHigh::Int, + price::Gold} + | Helmet { + itName::String, + damageLow::Int, + damageHigh::Int, + price::Gold} + | Potion { + itName::String, + potionType::PotionType, + price::Gold} + | Scroll { + itName::String, + spellType::String, + price::Gold} + | Trap { + itName::String, + damageLow::Int, + damageHigh::Int, + triggerDescription::String + } + deriving (Show,Read,Eq) + data Position= RightHand | LeftHand | Body | Head | Bag Int - deriving (Show,Read,Eq,Ord) + deriving (Show,Read,Eq,Ord) -- | Inventory Map item by Position Bag Size data Inventory = Inventory { - invItems::(M.Map Position ItemType), - invBagCapacity:: Int, - invGold:: Gold - } deriving (Eq,Show,Read) + invItems::(M.Map Position ItemType), + invBagCapacity:: Int, + invGold:: Gold + } deriving (Eq,Show,Read) type Gold=Int data InventoryError = InvalidBagPosition Int - | InvalidPositionForItem ItemType Position - deriving (Eq,Show,Read) + | InvalidPositionForItem ItemType Position + deriving (Eq,Show,Read) data PotionType = HealingPotion Int | MindPotion Int - deriving (Show,Read,Eq) + deriving (Show,Read,Eq) makeEmptyInventory :: Int -> Gold -> Inventory makeEmptyInventory a gold= Inventory M.empty a gold @@ -76,12 +76,12 @@ makeFullInventory :: [(Position,ItemType)] -> Gold -> Inventory makeFullInventory [] gold= makeEmptyInventory 0 gold makeFullInventory posAndItems gold= let - maxPos=maximum (map (getBagPos . fst) posAndItems) - in - reconcile2Hand (Inventory M.empty maxPos gold) posAndItems - where - getBagPos (Bag p)=p - getBagPos _ =0 + maxPos=maximum (map (getBagPos . fst) posAndItems) + in + reconcile2Hand (Inventory M.empty maxPos gold) posAndItems + where + getBagPos (Bag p)=p + getBagPos _ =0 --} makeFullInventory :: [(Position,ItemType)] -> Int -> Gold -> Inventory @@ -89,73 +89,73 @@ makeFullInventory posAndItems maxPos gold= reconcile2Hand (Inventory M.empty maxPos gold) posAndItems addGold :: Inventory -> Gold -> Inventory -addGold i g=let oldGold=invGold i - in i{invGold=max 0 (oldGold+g)} +addGold i g=let oldGold=invGold i + in i{invGold=max 0 (oldGold+g)} getGold :: Inventory -> Gold getGold i=invGold i reconcile2Hand :: Inventory -> [(Position,ItemType)] -> Inventory reconcile2Hand i poss=foldr f i poss - where - f:: (Position,ItemType) -> Inventory -> Inventory - f pos i= - case getCarriedItem i (fst pos) of - Right Nothing -> - let Right (i2,_)=takeItem i (snd pos) (fst pos) - in i2 - _->i + where + f:: (Position,ItemType) -> Inventory -> Inventory + f pos i= + case getCarriedItem i (fst pos) of + Right Nothing -> + let Right (i2,_)=takeItem i (snd pos) (fst pos) + in i2 + _->i takeItem :: Inventory -> ItemType -> Position -> Either InventoryError (Inventory,[ItemType]) takeItem i@(Inventory {invBagCapacity= sz}) it p= do - p2 <- checkPos sz p - ti1 <- takeItem' i it p2 True - takeTwoHandsItem ti1 it p2 - + p2 <- checkPos sz p + ti1 <- takeItem' i it p2 True + takeTwoHandsItem ti1 it p2 + takeTwoHandsItem ::(Inventory,Maybe ItemType) -> ItemType -> Position -> Either InventoryError (Inventory,[ItemType]) takeTwoHandsItem (i,it1) it@(Weapon {hands=2}) RightHand= do - (iv2,it2) <- takeItem' i it LeftHand (needSndDrop it1) - return (iv2,catMaybes [it1,it2]) + (iv2,it2) <- takeItem' i it LeftHand (needSndDrop it1) + return (iv2,catMaybes [it1,it2]) takeTwoHandsItem (i,it1) it@(Weapon {hands=2}) LeftHand= do - (iv2,it2) <- takeItem' i it RightHand (needSndDrop it1) - return (iv2,catMaybes [it1,it2]) + (iv2,it2) <- takeItem' i it RightHand (needSndDrop it1) + return (iv2,catMaybes [it1,it2]) takeTwoHandsItem (i,it1) _ _=do - return (i,catMaybes [it1]) - + return (i,catMaybes [it1]) + needSndDrop :: Maybe ItemType -> Bool needSndDrop (Just (Weapon {hands=2}))=False needSndDrop _=True takeItem' :: Inventory -> ItemType -> Position -> Bool -> Either InventoryError (Inventory,Maybe ItemType) takeItem' i it p needDrop= do - let allowed=positionAllowed it p - if allowed - then do - (i2@(Inventory {invItems=m}),it2) <- if needDrop - then dropItemToBag i p - else Right (i, Nothing) - return ((i2{invItems=(M.insert p it m)}),it2) - else Left (InvalidPositionForItem it p) + let allowed=positionAllowed it p + if allowed + then do + (i2@(Inventory {invItems=m}),it2) <- if needDrop + then dropItemToBag i p + else Right (i, Nothing) + return ((i2{invItems=(M.insert p it m)}),it2) + else Left (InvalidPositionForItem it p) dropItemToBag :: Inventory -> Position -> Either InventoryError (Inventory,Maybe ItemType) dropItemToBag i p@(Bag _)=dropItem i p dropItemToBag i p=do - mi2@(i2,it2)<- dropItem i p - if isJust it2 - then do - let freeBagPos=getFirstFreeBagPos i2 - if (isJust freeBagPos) - then do - (i3,_)<- takeItem i2 (fromJust it2) (fromJust freeBagPos) - return (i3,Nothing) - else - return mi2 - else return mi2 + mi2@(i2,it2)<- dropItem i p + if isJust it2 + then do + let freeBagPos=getFirstFreeBagPos i2 + if (isJust freeBagPos) + then do + (i3,_)<- takeItem i2 (fromJust it2) (fromJust freeBagPos) + return (i3,Nothing) + else + return mi2 + else return mi2 -instance Monad (Either InventoryError) where - Left a >>= _ = Left a - Right a >>= f = f a - return = Right +--instance Monad (Either InventoryError) where +-- Left a >>= _ = Left a +-- Right a >>= f = f a +-- return = Right getFirstFreeBagPos:: Inventory -> Maybe Position getFirstFreeBagPos (Inventory {invItems=m,invBagCapacity=sz})=listToMaybe $ (filter (flip M.notMember m) (map Bag [1 .. sz])) @@ -163,10 +163,10 @@ dropItem :: Inventory -> Position -> Either InventoryError (Inventory,Maybe ItemType) dropItem i@(Inventory {invItems=m,invBagCapacity=sz}) p = do - p2 <- checkPos sz p - let item = M.lookup p2 m - let m2 = M.delete p2 m - return (i{invItems=(dropTwoHandsItem m2 item p2)},item) + p2 <- checkPos sz p + let item = M.lookup p2 m + let m2 = M.delete p2 m + return (i{invItems=(dropTwoHandsItem m2 item p2)},item) dropTwoHandsItem ::(M.Map Position ItemType) -> Maybe ItemType -> Position -> (M.Map Position ItemType) dropTwoHandsItem m (Just (Weapon {hands=2})) RightHand= M.delete LeftHand m @@ -180,37 +180,37 @@ listItems :: Inventory -> [(Position,Maybe ItemType)] listItems (Inventory {invItems=m,invBagCapacity=sz}) = map - (\x -> (x,M.lookup x m)) - ([RightHand, LeftHand, Body, Head] ++ (map Bag [1..sz])) - -listCarriedItems :: Inventory -> [(Position,ItemType)] + (\x -> (x,M.lookup x m)) + ([RightHand, LeftHand, Body, Head] ++ (map Bag [1..sz])) + +listCarriedItems :: Inventory -> [(Position,ItemType)] listCarriedItems i = map (\(x,y)->(x,fromJust y)) (filter (isJust . snd) (listItems i)) - -listCarriedItemsUniqueType :: Inventory -> [(Position,ItemType)] + +listCarriedItemsUniqueType :: Inventory -> [(Position,ItemType)] listCarriedItemsUniqueType = nubBy (\x y -> (snd x)==(snd y)) . listCarriedItems -listCarriedItemsUniqueObject :: Inventory -> [(Position,ItemType)] +listCarriedItemsUniqueObject :: Inventory -> [(Position,ItemType)] listCarriedItemsUniqueObject = (filter f) . listCarriedItems - where - f (LeftHand,Weapon{hands=2})=False - f _=True - - + where + f (LeftHand,Weapon{hands=2})=False + f _=True + + getCarriedItem :: Inventory -> Position -> Either InventoryError (Maybe ItemType) getCarriedItem (Inventory {invItems=m,invBagCapacity=sz}) pos=do - p2<- checkPos sz pos - return (M.lookup p2 m) - + p2<- checkPos sz pos + return (M.lookup p2 m) + listActiveItems :: Inventory -> [ItemType] listActiveItems i= (map snd (filter (isActive . fst) (listCarriedItems i))) - + isActive :: Position -> Bool isActive (Bag {})=False isActive _ =True - + listAllowedPositions :: Inventory -> ItemType -> [(Position,Maybe ItemType)] listAllowedPositions i it=filter ((positionAllowed it) . fst) (listItems i) - + positionAllowed :: ItemType -> Position -> Bool -- everything can go in the bag positionAllowed _ (Bag {})=True diff --git a/src/MoresmauJP/Rpg/MazeObjectsTests.hs b/src/MoresmauJP/Rpg/MazeObjectsTests.hs --- a/src/MoresmauJP/Rpg/MazeObjectsTests.hs +++ b/src/MoresmauJP/Rpg/MazeObjectsTests.hs @@ -21,66 +21,66 @@ mazeObjectsTests=TestList [testScrollFill,testKillNPC,testKillNPC2HandBag,testKillNPC2HandHand] testScrollFill= TestLabel "Test filling scroll" (TestCase (do - let sc=Scroll "" "" 5 - sc2<-evalRandT (generateScroll sc) (mkTestWrapper [2]) - assertEqual "not proper scroll" (Scroll "Scroll of Feel Better" "Feel Better" 5) sc2 - )) - + let sc=Scroll "" "" 5 + sc2<-evalRandT (generateScroll sc) (mkTestWrapper [2]) + assertEqual "not proper scroll" (Scroll "Scroll of Feel Better" "Feel Better" 5) sc2 + )) + testKillNPC=TestLabel "Test kill NPC" (TestCase (do - std<-getStdGen - gw0<-(evalRandT (generateGameWorld (2,2)) (ProductionRandom std)) - - let - gw=gw0{position=(0,0)} - jp=createTestChar "JP" - item=Weapon "Sword" 2 6 1 10 - v1=(createTestNPC "Victim") - vc1=(npcCharacter v1){inventory=makeFullInventory [(Bag 1,item)] 10 100} - victim=v1{npcCharacter=vc1} - mz=MazeObjects M.empty (M.fromList [((0,0),victim)]) - (mz2,jp2,g)=killNPC gw mz jp - dropped=M.lookup (0,0) (items mz2) - assertEqual "Gold in JP's pocket is not 100" 100 (getGold $ inventory jp2) - assertEqual "Gold message is not 100" 100 g - assertEqual "item not dropped" (Just [item]) dropped - )) - + std<-getStdGen + gw0<-(evalRandT (generateGameWorld (2,2)) (ProductionRandom std)) + + let + gw=gw0{position=(0,0)} + jp=createTestChar "JP" + item=Weapon "Sword" 2 6 1 10 + v1=(createTestNPC "Victim") + vc1=(npcCharacter v1){inventory=makeFullInventory [(Bag 1,item)] 10 100} + victim=v1{npcCharacter=vc1} + mz=MazeObjects M.empty (M.fromList [((0,0),victim)]) + (mz2,jp2,g)=killNPC gw mz jp + dropped=M.lookup (0,0) (items mz2) + assertEqual "Gold in JP's pocket is not 100" 100 (getGold $ inventory jp2) + assertEqual "Gold message is not 100" 100 g + assertEqual "item not dropped" (Just [item]) dropped + )) + testKillNPC2HandBag=TestLabel "Test kill NPC 2 Handed weapon in Bag" (TestCase (do - std<-getStdGen - gw0<-(evalRandT (generateGameWorld (2,2)) (ProductionRandom std)) - - let - gw=gw0{position=(0,0)} - jp=createTestChar "JP" - item=Weapon "2 Handed Sword" 4 12 2 20 - v1=(createTestNPC "Victim") - vc1=(npcCharacter v1){inventory=makeFullInventory [(Bag 1,item)] 10 100} - victim=v1{npcCharacter=vc1} - mz=MazeObjects M.empty (M.fromList [((0,0),victim)]) - (mz2,jp2,g)=killNPC gw mz jp - dropped=M.lookup (0,0) (items mz2) - assertEqual "Gold in JP's pocket is not 100" 100 (getGold $ inventory jp2) - assertEqual "Gold message is not 100" 100 g - assertEqual "item not dropped" (Just [item]) dropped - )) - + std<-getStdGen + gw0<-(evalRandT (generateGameWorld (2,2)) (ProductionRandom std)) + + let + gw=gw0{position=(0,0)} + jp=createTestChar "JP" + item=Weapon "2 Handed Sword" 4 12 2 20 + v1=(createTestNPC "Victim") + vc1=(npcCharacter v1){inventory=makeFullInventory [(Bag 1,item)] 10 100} + victim=v1{npcCharacter=vc1} + mz=MazeObjects M.empty (M.fromList [((0,0),victim)]) + (mz2,jp2,g)=killNPC gw mz jp + dropped=M.lookup (0,0) (items mz2) + assertEqual "Gold in JP's pocket is not 100" 100 (getGold $ inventory jp2) + assertEqual "Gold message is not 100" 100 g + assertEqual "item not dropped" (Just [item]) dropped + )) + testKillNPC2HandHand=TestLabel "Test kill NPC 2 Handed weapon in Hand" (TestCase (do - std<-getStdGen - gw0<-(evalRandT (generateGameWorld (2,2)) (ProductionRandom std)) - - let - gw=gw0{position=(0,0)} - jp=createTestChar "JP" - item=Weapon "2 Handed Sword" 4 12 2 20 - v1=(createTestNPC "Victim") - inv1=makeFullInventory [] 10 100 - Right (inv2,_)=MoresmauJP.Rpg.Inventory.takeItem inv1 item RightHand - vc1=(npcCharacter v1){inventory=inv2} - victim=v1{npcCharacter=vc1} - mz=MazeObjects M.empty (M.fromList [((0,0),victim)]) - (mz2,jp2,g)=killNPC gw mz jp - dropped=M.lookup (0,0) (items mz2) - assertEqual "Gold in JP's pocket is not 100" 100 (getGold $ inventory jp2) - assertEqual "Gold message is not 100" 100 g - assertEqual "item not dropped" (Just [item]) dropped - )) + std<-getStdGen + gw0<-(evalRandT (generateGameWorld (2,2)) (ProductionRandom std)) + + let + gw=gw0{position=(0,0)} + jp=createTestChar "JP" + item=Weapon "2 Handed Sword" 4 12 2 20 + v1=(createTestNPC "Victim") + inv1=makeFullInventory [] 10 100 + Right (inv2,_)=MoresmauJP.Rpg.Inventory.takeItem inv1 item RightHand + vc1=(npcCharacter v1){inventory=inv2} + victim=v1{npcCharacter=vc1} + mz=MazeObjects M.empty (M.fromList [((0,0),victim)]) + (mz2,jp2,g)=killNPC gw mz jp + dropped=M.lookup (0,0) (items mz2) + assertEqual "Gold in JP's pocket is not 100" 100 (getGold $ inventory jp2) + assertEqual "Gold message is not 100" 100 g + assertEqual "item not dropped" (Just [item]) dropped + )) diff --git a/src/MoresmauJP/Util/Lists.hs b/src/MoresmauJP/Util/Lists.hs --- a/src/MoresmauJP/Util/Lists.hs +++ b/src/MoresmauJP/Util/Lists.hs @@ -38,7 +38,6 @@ occurenceList :: [(a,Int)] -> [a] occurenceList itemOccurences=concat (foldl (\l (it,oc)->(take oc (repeat it)):l) [] itemOccurences) - randomPickp:: (MonadRandom m)=> [a] -> m a randomPickp [] = error "randomPickp cannot run on an empty list"