-------------------------------------------------------------------------
--
--  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 hiding (defaultTimeLocale)
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 Move -> Move -> Bool
(Move -> Move -> Bool) -> (Move -> Move -> Bool) -> Eq Move
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Move -> Move -> Bool
== :: Move -> Move -> Bool
$c/= :: Move -> Move -> Bool
/= :: Move -> Move -> Bool
Eq

-- Showing Moves in an abbreviated form.

instance Show Move where
      show :: Move -> String
show Move
Rock = String
"r"
      show Move
Paper = String
"p"
      show Move
Scissors = String
"s"

-- For QuickCheck to work over the Move type.

instance Arbitrary Move where
  arbitrary :: Gen Move
arbitrary     = [Move] -> Gen Move
forall a. HasCallStack => [a] -> Gen a
elements [Move
Rock, Move
Paper, Move
Scissors]

-- Convert from 0,1,2 to a Move

convertToMove :: Integer -> Move

convertToMove :: Integer -> Move
convertToMove Integer
0 = Move
Rock
convertToMove Integer
1 = Move
Paper
convertToMove Integer
2 = Move
Scissors

-- Convert a character to the corresponding Move element.
  
convertMove :: Char -> Move
    
convertMove :: Char -> Move
convertMove Char
'r' = Move
Rock
convertMove Char
'R' = Move
Rock
convertMove Char
'p' = Move
Paper
convertMove Char
'P' = Move
Paper
convertMove Char
's' = Move
Scissors
convertMove Char
'S' = Move
Scissors

-- Outcome of a play
--   +1 for first player wins
--   -1 for second player wins
--    0 for a draw

outcome :: Move -> Move -> Integer

outcome :: Move -> Move -> Integer
outcome = Move -> Move -> Integer
outcome -- dummy def

-- Outcome of a tournament

tournamentOutcome :: Tournament -> Integer

tournamentOutcome :: Tournament -> Integer
tournamentOutcome = Tournament -> Integer
tournamentOutcome -- dummy definition

-- Calculating the Move to beat or lose against the 
-- argument Move.

beat, lose :: Move -> Move

beat :: Move -> Move
beat Move
Rock = Move
Paper
beat Move
Paper = Move
Scissors
beat Move
Scissors = Move
Rock

lose :: Move -> Move
lose Move
Rock = Move
Scissors
lose Move
Paper = Move
Rock
lose Move
Scissors = Move
Paper

-- QuickCheck property about the "sanity" of the 
-- beat and lose functions.

prop_WinLose :: Move -> Bool

prop_WinLose :: Move -> Bool
prop_WinLose Move
x =
    Move -> Move
beat Move
x Move -> Move -> Bool
forall a. Eq a => a -> a -> Bool
/= Move -> Move
lose Move
x Bool -> Bool -> Bool
&&
    Move -> Move
beat Move
x Move -> Move -> Bool
forall a. Eq a => a -> a -> Bool
/= Move
x Bool -> Bool -> Bool
&&
    Move -> Move
lose Move
x Move -> Move -> Bool
forall a. Eq a => a -> a -> Bool
/= Move
x


--
-- Strategies
--

type Strategy = [Move] -> Move

-- Random choice of Move

randomStrategy :: Strategy
randomStrategy :: Strategy
randomStrategy [Move]
_ = Integer -> Move
convertToMove (Integer -> Move) -> Integer -> Move
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
randInt Integer
3

-- Constant strategies

sConst :: Move -> Strategy

sConst :: Move -> Strategy
sConst Move
x [Move]
_ = Move
x

rock, paper, scissors :: Strategy

rock :: Strategy
rock     = Move -> Strategy
sConst Move
Rock
paper :: Strategy
paper    = Move -> Strategy
sConst Move
Paper
scissors :: Strategy
scissors = Move -> Strategy
sConst Move
Scissors

-- Cycle through the three moves.

cycle :: Strategy

cycle :: Strategy
cycle [Move]
moves
  = case ([Move] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Move]
moves) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
3 of 
      Int
0 -> Move
Rock
      Int
1 -> Move
Paper
      Int
2 -> Move
Scissors

-- Play the move that would have lost the opponent's last play.

sLostLast :: Move -> Strategy

sLostLast :: Move -> Strategy
sLostLast Move
move = Strategy
rock -- dummy definition --- for you to complete

-- Echo the previous move; also have to supply starting Move.

echo :: Move -> Strategy

echo :: Move -> Strategy
echo Move
start [Move]
moves 
      = case [Move]
moves of
          []       -> Move
start
          (Move
last:[Move]
_) -> Move
last

-- Make a random choice of which Strategy to use, 
-- each turn.

sToss :: Strategy -> Strategy -> Strategy

sToss :: Strategy -> Strategy -> Strategy
sToss Strategy
str1 Strategy
str2 [Move]
moves =
    case Integer -> Integer
randInt Integer
2 of
      Integer
1 -> Strategy
str1 [Move]
moves
      Integer
0 -> Strategy
str2 [Move]
moves

--
-- Random stuff from time
--

-- Generate a random integer within the IO monad.

randomInt :: Integer -> IO Integer

randomInt :: Integer -> IO Integer
randomInt Integer
n = 
    do
      UTCTime
time <- IO UTCTime
getCurrentTime
      Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Integer
n) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
6 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%q" UTCTime
time)

-- Extract the random number from the IO monad, unsafely!

randInt :: Integer -> Integer

randInt :: Integer -> Integer
randInt = IO Integer -> Integer
forall a. IO a -> a
unsafePerformIO (IO Integer -> Integer)
-> (Integer -> IO Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> IO Integer
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 :: IO ()
helloWorld = String -> IO ()
putStr String
"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 :: String -> IO ()
put4times String
str 
  = do String -> IO ()
putStrLn String
str
       String -> IO ()
putStrLn String
str
       String -> IO ()
putStrLn String
str
       String -> IO ()
putStrLn String
str

-- Put n times

putNtimes :: Integer -> String -> IO ()
putNtimes :: Integer -> String -> IO ()
putNtimes Integer
n String
str
  = if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
1 
       then String -> IO ()
putStrLn String
str
       else do String -> IO ()
putStrLn String
str
               Integer -> String -> IO ()
putNtimes (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) String
str

-- Read two lines, then write a message.

read2lines :: IO ()
read2lines :: IO ()
read2lines 
  = do IO String
getLine
       IO String
getLine
       String -> IO ()
putStrLn String
"Two lines read."

-- Read then write.

getNput :: IO ()
getNput :: IO ()
getNput = do String
line <- IO String
getLine
             String -> IO ()
putStrLn String
line

-- Read, process then write.

reverse2lines :: IO ()
reverse2lines :: IO ()
reverse2lines
  = do String
line1 <- IO String
getLine
       String
line2 <- IO String
getLine
       String -> IO ()
putStrLn (ShowS
forall a. [a] -> [a]
reverse String
line2)
       String -> IO ()
putStrLn (ShowS
forall a. [a] -> [a]
reverse String
line1)

-- Last example redefined to use a local definition.

reverse2lines' :: IO ()
reverse2lines' :: IO ()
reverse2lines'
  = do String
line1 <- IO String
getLine
       String
line2 <- IO String
getLine
       let rev1 :: String
rev1 = ShowS
forall a. [a] -> [a]
reverse String
line1
       let rev2 :: String
rev2 = ShowS
forall a. [a] -> [a]
reverse String
line2
       String -> IO ()
putStrLn String
rev2
       String -> IO ()
putStrLn String
rev1

-- Reading an Int.

getInt :: IO Integer
getInt :: IO Integer
getInt = do String
line <- IO String
getLine
            Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Integer
forall a. Read a => String -> a
read String
line :: Integer) 



-- Simple examples

readWrite :: IO ()

readWrite :: IO ()
readWrite =
    do
      IO String
getLine
      String -> IO ()
putStrLn String
"one line read"

readEcho :: IO ()

readEcho :: IO ()
readEcho =
    do
      String
line <-IO String
getLine
      String -> IO ()
putStrLn (String
"line read: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
line)


-- Adding a sequence of integers

sumInts :: Integer -> IO Integer

sumInts :: Integer -> IO Integer
sumInts Integer
s
  = do Integer
n <- IO Integer
getInt
       if Integer
nInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0 
          then Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
s
          else Integer -> IO Integer
sumInts (Integer
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
n)

-- Addiing a sequence of integers, courteously.

sumInteract :: IO ()
sumInteract :: IO ()
sumInteract
  = do String -> IO ()
putStrLn String
"Enter integers one per line"
       String -> IO ()
putStrLn String
"These will be summed until zero is entered"
       Integer
sum <- Integer -> IO Integer
sumInts Integer
0
       String -> IO ()
putStr String
"The sum is "
       Integer -> IO ()
forall a. Show a => a -> IO ()
print Integer
sum

-- Copy from input to output

copyEOF :: IO ()

copyEOF :: IO ()
copyEOF = 
    do 
      Bool
eof <- IO Bool
isEOF
      if Bool
eof  
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () 
        else do String
line <- IO String
getLine 
                String -> IO ()
putStrLn String
line
                IO ()
copyEOF

copyInteract :: IO ()

copyInteract :: IO ()
copyInteract = 
    do
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
LineBuffering
      IO ()
copyEOF
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering

copy :: IO ()

copy :: IO ()
copy =
    do String
line <- IO String
getLine 
       String -> IO ()
putStrLn String
line
       IO ()
copy
      
copyEmpty :: IO ()

copyEmpty :: IO ()
copyEmpty =
    do String
line <- IO String
getLine 
       if String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
          then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else do String -> IO ()
putStrLn String
line
                  IO ()
copyEmpty


copyCount :: Integer -> IO ()

copyCount :: Integer -> IO ()
copyCount Integer
n =
    do String
line <- IO String
getLine 
       if String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
          then String -> IO ()
putStrLn (Integer -> String
forall a. Show a => a -> String
show Integer
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" lines copied.")
          else do String -> IO ()
putStrLn String
line
                  Integer -> IO ()
copyCount (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)

copyN :: Integer -> IO ()

copyN :: Integer -> IO ()
copyN Integer
n =
    if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
    then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do String
line <- IO String
getLine
            String -> IO ()
putStrLn String
line
            Integer -> IO ()
copyN (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)

copyWrong :: IO ()

copyWrong :: IO ()
copyWrong =
    do
      String
line <- IO String
getLine
      let whileCopy :: IO ()
whileCopy = 
              do
                if (String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"")
                  then (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                  else 
                    do String -> IO ()
putStrLn String
line
                       String
line <- IO String
getLine
                       IO ()
whileCopy 
      IO ()
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 :: Tournament -> Integer
result = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer)
-> (Tournament -> [Integer]) -> Tournament -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Move, Move) -> Integer) -> [(Move, Move)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map ((Move -> Move -> Integer) -> (Move, Move) -> Integer
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Move -> Move -> Integer
outcome) ([(Move, Move)] -> [Integer])
-> (Tournament -> [(Move, Move)]) -> Tournament -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Move] -> [Move] -> [(Move, Move)])
-> Tournament -> [(Move, Move)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Move] -> [Move] -> [(Move, Move)]
forall a b. [a] -> [b] -> [(a, b)]
zip


--
-- Play one Strategy against another
--

step :: Strategy -> Strategy -> Tournament -> Tournament

step :: Strategy -> Strategy -> Tournament -> Tournament
step Strategy
strategyA Strategy
strategyB ( [Move]
movesA, [Move]
movesB )
     = ( Strategy
strategyA [Move]
movesB Move -> [Move] -> [Move]
forall a. a -> [a] -> [a]
: [Move]
movesA , Strategy
strategyB [Move]
movesA Move -> [Move] -> [Move]
forall a. a -> [a] -> [a]
: [Move]
movesB )

playSvsS :: Strategy -> Strategy -> Integer -> Tournament

playSvsS :: Strategy -> Strategy -> Integer -> Tournament
playSvsS Strategy
strategyA Strategy
strategyB Integer
n
     = String -> Tournament
forall a. HasCallStack => String -> a
error String
"exercise"


--
-- Playing interactively
--

-- Top-level function

play :: Strategy -> IO ()

play :: Strategy -> IO ()
play Strategy
strategy =
    Strategy -> Tournament -> IO ()
playInteractive Strategy
strategy ([],[])

-- The worker function

playInteractive :: Strategy -> Tournament -> IO ()

playInteractive :: Strategy -> Tournament -> IO ()
playInteractive Strategy
s t :: Tournament
t@([Move]
mine,[Move]
yours) =
    do 
      Char
ch <- IO Char
getChar
      if Bool -> Bool
not (Char
ch Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"rpsRPS") 
        then Tournament -> IO ()
showResults Tournament
t 
        else do let next :: Move
next = Strategy
s [Move]
yours 
                String -> IO ()
putStrLn (String
"\nI play: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Move -> String
forall a. Show a => a -> String
show Move
next String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" you play: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
ch])
                let yourMove :: Move
yourMove = Char -> Move
convertMove Char
ch
                Strategy -> Tournament -> IO ()
playInteractive Strategy
s (Move
nextMove -> [Move] -> [Move]
forall a. a -> [a] -> [a]
:[Move]
mine, Move
yourMoveMove -> [Move] -> [Move]
forall a. a -> [a] -> [a]
:[Move]
yours)


-- Calculate the winner and report the result.

showResults :: Tournament -> IO ()

showResults :: Tournament -> IO ()
showResults Tournament
t = 
    do
      let res :: Integer
res = Tournament -> Integer
result Tournament
t
      String -> IO ()
putStrLn (case Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
res Integer
0 of
                  Ordering
GT ->  String
"I won!"
                  Ordering
EQ -> String
"Draw!"
                  Ordering
LT -> String
"You won: well done!")
      
-- Play against a randomly chosen strategy

randomPlay :: IO ()

randomPlay :: IO ()
randomPlay =
    do
      Integer
rand <- Integer -> IO Integer
randomInt Integer
10
      Strategy -> IO ()
play (case Integer
rand of
            Integer
0 -> Move -> Strategy
echo Move
Paper
            Integer
1 -> Move -> Strategy
sLostLast Move
Scissors
            Integer
2 -> Move -> Strategy
forall a b. a -> b -> a
const Move
Rock
            Integer
3 -> Strategy
randomStrategy
            Integer
4 -> Strategy -> Strategy -> Strategy
sToss Strategy
randomStrategy (Move -> Strategy
echo Move
Paper)
            Integer
5 -> Move -> Strategy
echo Move
Rock
            Integer
6 -> Move -> Strategy
sLostLast Move
Paper
            Integer
7 -> Strategy -> Strategy -> Strategy
sToss (Move -> Strategy
forall a b. a -> b -> a
const Move
Rock) (Move -> Strategy
forall a b. a -> b -> a
const Move
Scissors)
            Integer
8 -> Move -> Strategy
forall a b. a -> b -> a
const Move
Paper
            Integer
9 -> Strategy
randomStrategy)