My take on the orc thingie

orc.hs

{-# LANGUAGE Rank2Types #-}
module Main where
import System.Random
import Control.Monad
import Control.Monad.State
import Data.List

data Player = Player  { pHealth :: Int
                      , pAgility :: Int
                      , pStrength :: Int 
                      } deriving Show
              
pDead p = pHealth p <= 0
pAlive p = not $ pDead p

playerDescription (Player h a s) =
  "You are a valiant knight with :\n" 
  ++  "- " ++ (show h) ++ " health\n"
  ++  "- " ++ (show a) ++ " agility\n"
  ++  "- " ++ (show s) ++ " strength\n"
  
data Monster = Monster { mHp :: Int
                       , mDescription :: String
                       , mHit :: Int -> Monster
                       , mAttack :: (RandomGen a, MonadState a m) => Player -> m MonsterAttack 
                       , mShow :: String
                       }
               
instance Show Monster where
  show m = (if mDead m then "Dead" else "")
           ++ "Monster (" ++ mShow m ++ ")"       

data MonsterAttack = MonsterAttack { maText :: String
                                   , maMonster :: Monster
                                   , maPlayer :: Player
                                   } deriving Show

mDead m = mHp m <= 0
mAlive m = not $ mDead m

monsterDescription m 
  | mDead m = mDescription m ++ " *Dead*"
  | otherwise = mDescription m
                                         

rVal max gen = 
  randomR (1, max) gen

mrVal :: (RandomGen a, MonadState a m) => Int -> m Int
mrVal max = 
  do gen <- get
     let (value, newGen) = rVal max gen
     put newGen
     return value                              
     
data Orc = Orc { oHealth :: Int
               , clubLevel :: Int
               } deriving Show
                      
newOrc m@(Orc health clubLevel) =
  monster
  where monster = Monster health description hit attack mShow
        mShow = show m
        description = "A wicked Orc with a level " ++ show clubLevel ++ " club."
        hit dmg = newOrc $ Orc (health - dmg) clubLevel
        attack :: (RandomGen a, MonadState a m) => Player -> m MonsterAttack
        attack (Player h a s) =                     
          do dmg <- mrVal clubLevel
             let text = "An Orc swings his club at you and knocks off " ++ show dmg ++
                     " of your health points."
                 player = Player (h - dmg) a s
             return $ MonsterAttack text monster player     
               
orcBuilder :: (RandomGen a, MonadState a m) => m Monster
orcBuilder = do health <- mrVal 10
                clubLevel <- mrVal 8
                return $ newOrc $ Orc health clubLevel
                
data Hydra = Hydra { hHeads :: Int } deriving Show

newHydra m@(Hydra health) =
  monster
  where monster = Monster health description hit attack mShow
        mShow = show m        
        description = "A malicious hydra with " ++ show health ++ " heads." 
        hit dmg = newHydra $ Hydra $ health - dmg
        attack (Player h a s) =
          do dmg <- mrVal $ div health 2
             let text = "A Hydra attacks you with " ++ show health ++ " of its heads, dealing " ++ show dmg ++ 
                        " damage. It also grows back one more head."
                 player = Player (h - dmg) a s                 
                 hydra = newHydra $ Hydra (health + 1)
             return $ MonsterAttack text hydra player

hydraBuilder :: (RandomGen a, MonadState a m) => m Monster
hydraBuilder = do health <- mrVal 10
                  return $ newHydra $ Hydra health
                  
data Brigand = Brigand { bHealth :: Int } deriving Show
                  
newBrigand m@(Brigand health) =
  monster
  where monster = Monster health description hit attack mShow
        mShow = show m
        description = "A fierce Brigand."
        hit dmg = newBrigand $ Brigand $ health - dmg
        attack :: (RandomGen a, MonadState a m) => Player -> m MonsterAttack
        attack (Player h a s) = chooseBest $ maximum [h, a, s]
          where chooseBest b
                  | b == h = let text = "A Brigand hits you with his slingshot, taking off 2 health points."
                                 player = Player (h - 2) a s
                             in return $ MonsterAttack text monster player
                  | b == a = let text = "A Brigand catches your leg with his whip, taking off 2 agility points."
                                 player = Player h (a - 2) s
                             in return $ MonsterAttack text monster player
                  | otherwise = let text = "A brigand cuts your arm with his knife, taking off 2 strength points."
                                    player = Player h a (s - 2)
                                in return $ MonsterAttack text monster player

brigandBuilder :: (RandomGen a, MonadState a m) => m Monster                
brigandBuilder = do health <- mrVal 10
                    return $ newBrigand $ Brigand health                  
                
data Slime = Slime { sHealth :: Int
                   , sliminess :: Int 
                   } deriving Show
                 
newSlime m@(Slime health sliminess) =
  monster
  where monster = Monster health description hit attack mShow
        mShow = show m
        description = "A Slime mold with a sliminess of " ++ show sliminess ++ "."
        hit dmg = newSlime $ Slime (health - dmg) sliminess
        attack :: (RandomGen a, MonadState a m) => Player -> m MonsterAttack
        attack (Player h a s) = 
          do dmg <- mrVal sliminess
             let text = "A Slime mold wraps around your legs and decreases your agility by " ++ show dmg ++ "."
                 agi = (a - dmg)
                 doSquirt 1 = MonsterAttack 
                              (text ++ " It also squirts in your face, taking away a health point.")
                              monster $ Player (h - 1) agi s
                 doSquirt _ = MonsterAttack text monster $ Player h agi s               
             squirt <- mrVal 3
             return $ doSquirt (squirt :: Int)

slimeBuilder :: (RandomGen a, MonadState a m) => m Monster
slimeBuilder = do health <- mrVal 10
                  sliminess <- mrVal 5
                  return $ newSlime $ Slime  health sliminess
  
monsterBuilders :: (RandomGen a, MonadState a m) => [m Monster]
monsterBuilders = [orcBuilder, hydraBuilder, brigandBuilder, slimeBuilder]

randomMonster :: (RandomGen a, MonadState a m) => [m Monster] -> m Monster
randomMonster builders = do idx <- mrVal $ length builders
                            builders !! (idx - 1)
                           
monsterCount = 12

randomMonsters :: (RandomGen a, MonadState a m) => m [Monster]
randomMonsters = replicateM monsterCount $ randomMonster monsterBuilders

data PlayerAttack = Stab
                  | DoubleSwing Int
                  | RoundHouse
                  deriving Show

data WorldState = Starting Player [Monster]
                | Fight Player [Monster]
                | PickMonster Player [Monster]
                | Attack Player [Monster] PlayerAttack
                | MonstersTurn Player [Monster]
                | Victory
                | Death                  
                deriving Show
                         
initWorld :: (RandomGen a, MonadState a m) => m WorldState 
initWorld =
  let player = Player 30 30 30
  in do monsters <- randomMonsters
        return $ Starting player monsters 

monstersText :: [Monster] -> String                 
monstersText monsters = 
  snd $ foldl addMonster (1,"") monsters
  where 
    addMonster (idx, text) m = ((idx + 1), text ++ showOne idx m)
    showOne idx m = show idx ++ " - " ++ mDescription m ++ (if mDead m then " *Dead*" else "") ++ "\n"


data StateAction = StateAction { displayMessage :: String
                               , performAction :: Action
                               }
                 | Done String
                 deriving Show

data Action = PlayerActions [PlayerAction]
            | StateChange WorldState
            deriving Show
              
data PlayerAction = PlayerAction { playerInput :: String
                                 , newWorldState :: WorldState
                                 }
                  deriving Show

randomStrength player =
  do r <- mrVal $ div (pStrength player - 1) 2
     return $ r + 2
     
updateAt f idx currIdx [] = []
updateAt f idx currIdx (x:xs) 
  | idx == currIdx = f x : updateAt f idx (currIdx + 1) xs
  | otherwise = x : updateAt f idx (currIdx + 1) xs
                
liveIndexes monsters = map fst $ filter (mAlive . snd) $ zip [0..] monsters

updateRandomMonster monsters f = 
  let indexes = liveIndexes monsters
      len = length indexes
  in do idx <- mrVal len
        let monsters' = updateAt f (indexes !! (idx - 1)) 0 monsters
        return monsters'     

allMonstersDead monsters = all mDead monsters

afterAttack text p monsters =  
  if allMonstersDead monsters then
    return $ StateAction text $ StateChange Victory
  else
    return $ StateAction text $ StateChange $ MonstersTurn p monsters

stateAction (Starting p ms) =
  let text = "A horde of monsters is attacking you.\n"
      sChange = StateChange $ Fight p ms
  in return $ StateAction text sChange
     
stateAction (Fight p ms) =
  let text = playerDescription p ++ "\n" ++ monstersText ms ++ 
             "\nWill you [s]tab, [d]ouble swing or [r]oundhouse kick ?"      
      actions = PlayerActions [ PlayerAction "s" $ Attack p ms Stab
                              , PlayerAction "d" $ PickMonster p ms
                              , PlayerAction "r" $ Attack p ms RoundHouse
                              ]
  in return $ StateAction text actions 

stateAction (Attack p ms Stab) = 
  do dmg <- randomStrength p
     let text = "You stab a random monster, dealing " ++ show dmg ++ " damage.\n"
     monsters <- updateRandomMonster ms (`mHit` dmg)
     afterAttack text p monsters
     
stateAction (Attack p ms RoundHouse) =
  let times = 1 + div (pStrength p) 3
      text = "Your kick hits " ++ show times ++ " times.\n"
      doTimes 0 monsters = return monsters
      doTimes count ms = do monsters <- updateRandomMonster ms $ (`mHit` 1)
                            doTimes (count - 1) monsters
  in do monsters <- doTimes times ms
        afterAttack text p monsters
        
stateAction (Attack p ms (DoubleSwing idx)) =
  do dmg <- mrVal  $ div (pStrength p) 6
     let monsters = updateAt (`mHit` (2 * dmg)) idx 1 ms
         text = "You swing twice at monster " ++ show (idx ) ++ ", dealing " ++ show dmg 
                ++ " damage each time.\n"
     afterAttack text p monsters

stateAction (PickMonster p ms) = 
  let text = "Choose the (living) monster to attack:"      
      playerAction idx = PlayerAction (show idx) $ Attack p ms (DoubleSwing idx)
      actions = PlayerActions $ map playerAction $ map fst $ filter (mAlive . snd) $ zip [1..] ms
  in return $ StateAction text actions
      
stateAction (MonstersTurn p ms) = 
  let text = "The monsters are attacking you !\n"
      doAttack (text, player, monsters) m 
        | mDead m = return (text, player, monsters ++ [m])
        | mAlive m = do (MonsterAttack t m' p) <- mAttack m player
                        return (text ++ "\n- " ++ t, p, monsters ++ [m'])      
  in do (texts, player, monsters) <- foldM doAttack (text, p, []) ms
        if pDead player then
          return $ StateAction (texts ++ "\n") $ StateChange Death
        else
          return $ StateAction (texts ++ "\n") $ StateChange $ Fight player monsters
          
stateAction Death = return $ Done "You are dead..." 
stateAction Victory = return $ Done "You are victorious !"

--------------------------------
-- IO stuff

main = do gen <- newStdGen
          let (ws, gen') = runState initWorld gen
          gameLoop ws gen'

gameLoop ws gen =
  let (sa, gen') = runState (stateAction ws) gen
  in case sa of
    (Done txt) -> putStrLn txt
    (StateAction txt action) -> do putStrLn txt
                                   doAction action gen'
                                   
doAction (StateChange ws) gen = gameLoop ws gen
doAction a@(PlayerActions actions) gen =
  let actionForInput input = find matchAction actions
        where matchAction a = input == (playerInput a)
  in do input <- getLine
        case actionForInput input of
          Nothing -> do putStrLn "invalid input"
                        doAction a gen
          (Just pa) -> gameLoop (newWorldState pa) gen