------------------------------------------------------------------------- -- -- Haskell: The Craft of Functional Programming, 3e -- Simon Thompson -- (c) Addison-Wesley, 1996-2011. -- -- Chapter 8 -- ------------------------------------------------------------------------- module Chapter8 where import Data.Time import System.Locale import System.IO.Unsafe import System.IO import Test.QuickCheck -- -- Basic types and functions over the type -- -- A type of moves data Move = Rock | Paper | Scissors deriving Eq -- Showing Moves in an abbreviated form. instance Show Move where show Rock = "r" show Paper = "p" show Scissors = "s" -- For QuickCheck to work over the Move type. instance Arbitrary Move where arbitrary = elements [Rock, Paper, Scissors] -- Convert from 0,1,2 to a Move convertToMove :: Integer -> Move convertToMove 0 = Rock convertToMove 1 = Paper convertToMove 2 = Scissors -- Convert a character to the corresponding Move element. convertMove :: Char -> Move convertMove 'r' = Rock convertMove 'R' = Rock convertMove 'p' = Paper convertMove 'P' = Paper convertMove 's' = Scissors convertMove 'S' = Scissors -- Outcome of a play -- +1 for first player wins -- -1 for second player wins -- 0 for a draw outcome :: Move -> Move -> Integer outcome = outcome -- dummy def -- Outcome of a tournament tournamentOutcome :: Tournament -> Integer tournamentOutcome = tournamentOutcome -- dummy definition -- Calculating the Move to beat or lose against the -- argument Move. beat, lose :: Move -> Move beat Rock = Paper beat Paper = Scissors beat Scissors = Rock lose Rock = Scissors lose Paper = Rock lose Scissors = Paper -- QuickCheck property about the "sanity" of the -- beat and lose functions. prop_WinLose :: Move -> Bool prop_WinLose x = beat x /= lose x && beat x /= x && lose x /= x -- -- Strategies -- type Strategy = [Move] -> Move -- Random choice of Move randomStrategy :: Strategy randomStrategy _ = convertToMove $ randInt 3 -- Constant strategies sConst :: Move -> Strategy sConst x _ = x rock, paper, scissors :: Strategy rock = sConst Rock paper = sConst Paper scissors = sConst Scissors -- Cycle through the three moves. cycle :: Strategy cycle moves = case (length moves) `rem` 3 of 0 -> Rock 1 -> Paper 2 -> Scissors -- Play the move that would have lost the opponent's last play. sLostLast :: Move -> Strategy sLostLast move = rock -- dummy definition --- for you to complete -- Echo the previous move; also have to supply starting Move. echo :: Move -> Strategy echo start moves = case moves of [] -> start (last:_) -> last -- Make a random choice of which Strategy to use, -- each turn. sToss :: Strategy -> Strategy -> Strategy sToss str1 str2 moves = case randInt 2 of 1 -> str1 moves 0 -> str2 moves -- -- Random stuff from time -- -- Generate a random integer within the IO monad. randomInt :: Integer -> IO Integer randomInt n = do time <- getCurrentTime return ( (`rem` n) $ read $ take 6 $ formatTime defaultTimeLocale "%q" time) -- Extract the random number from the IO monad, unsafely! randInt :: Integer -> Integer randInt = unsafePerformIO . randomInt --- Basics of I/O --- ^^^^^^^^^^^^^ -- The basics of input/output -- ^^^^^^^^^^^^^^^^^^^^^^^^^^ -- Reading input is done by getLine and getChar: see Prelude for details. -- getLine :: IO String -- getChar :: IO Char -- Text strings are written using -- -- putStr :: String -> IO () -- putStrLn :: String -> IO () -- A hello, world program helloWorld :: IO () helloWorld = putStr "Hello, World!" -- Writing values in general -- print :: Show a => a -> IO () -- The do notation: a series of sequencing examples. -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -- Put a string and newline. -- putStrLn :: String -> IO () -- putStrLn str = do putStr str -- putStr "\n" -- Put four times. put4times :: String -> IO () put4times str = do putStrLn str putStrLn str putStrLn str putStrLn str -- Put n times putNtimes :: Integer -> String -> IO () putNtimes n str = if n <= 1 then putStrLn str else do putStrLn str putNtimes (n-1) str -- Read two lines, then write a message. read2lines :: IO () read2lines = do getLine getLine putStrLn "Two lines read." -- Read then write. getNput :: IO () getNput = do line <- getLine putStrLn line -- Read, process then write. reverse2lines :: IO () reverse2lines = do line1 <- getLine line2 <- getLine putStrLn (reverse line2) putStrLn (reverse line1) -- Last example redefined to use a local definition. reverse2lines' :: IO () reverse2lines' = do line1 <- getLine line2 <- getLine let rev1 = reverse line1 let rev2 = reverse line2 putStrLn rev2 putStrLn rev1 -- Reading an Int. getInt :: IO Integer getInt = do line <- getLine return (read line :: Integer) -- Simple examples readWrite :: IO () readWrite = do getLine putStrLn "one line read" readEcho :: IO () readEcho = do line <-getLine putStrLn ("line read: " ++ line) -- Adding a sequence of integers sumInts :: Integer -> IO Integer sumInts s = do n <- getInt if n==0 then return s else sumInts (s+n) -- Addiing a sequence of integers, courteously. sumInteract :: IO () sumInteract = do putStrLn "Enter integers one per line" putStrLn "These will be summed until zero is entered" sum <- sumInts 0 putStr "The sum is " print sum -- Copy from input to output copyEOF :: IO () copyEOF = do eof <- isEOF if eof then return () else do line <- getLine putStrLn line copyEOF copyInteract :: IO () copyInteract = do hSetBuffering stdin LineBuffering copyEOF hSetBuffering stdin NoBuffering copy :: IO () copy = do line <- getLine putStrLn line copy copyEmpty :: IO () copyEmpty = do line <- getLine if line == "" then return () else do putStrLn line copyEmpty copyCount :: Integer -> IO () copyCount n = do line <- getLine if line == "" then putStrLn (show n ++ " lines copied.") else do putStrLn line copyCount (n+1) copyN :: Integer -> IO () copyN n = if n <= 0 then return () else do line <- getLine putStrLn line copyN (n-1) copyWrong :: IO () copyWrong = do line <- getLine let whileCopy = do if (line == "") then (return ()) else do putStrLn line line <- getLine whileCopy whileCopy --- Playing Rock - Paper - Scissors --- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -- -- Tournaments -- -- The Tournament type. type Tournament = ([Move],[Move]) -- The result of a Tournament, calculates the outcome of each -- stage and sums the results. result :: Tournament -> Integer result = sum . map (uncurry outcome) . uncurry zip -- -- Play one Strategy against another -- step :: Strategy -> Strategy -> Tournament -> Tournament step strategyA strategyB ( movesA, movesB ) = ( strategyA movesB : movesA , strategyB movesA : movesB ) playSvsS :: Strategy -> Strategy -> Integer -> Tournament playSvsS strategyA strategyB n = error "exercise" -- -- Playing interactively -- -- Top-level function play :: Strategy -> IO () play strategy = playInteractive strategy ([],[]) -- The worker function playInteractive :: Strategy -> Tournament -> IO () playInteractive s t@(mine,yours) = do ch <- getChar if not (ch `elem` "rpsRPS") then showResults t else do let next = s yours putStrLn ("\nI play: " ++ show next ++ " you play: " ++ [ch]) let yourMove = convertMove ch playInteractive s (next:mine, yourMove:yours) -- Calculate the winner and report the result. showResults :: Tournament -> IO () showResults t = do let res = result t putStrLn (case compare res 0 of GT -> "I won!" EQ -> "Draw!" LT -> "You won: well done!") -- Play against a randomly chosen strategy randomPlay :: IO () randomPlay = do rand <- randomInt 10 play (case rand of 0 -> echo Paper 1 -> sLostLast Scissors 2 -> const Rock 3 -> randomStrategy 4 -> sToss randomStrategy (echo Paper) 5 -> echo Rock 6 -> sLostLast Paper 7 -> sToss (const Rock) (const Scissors) 8 -> const Paper 9 -> randomStrategy)