module Chapter8 where
import Data.Time
import System.Locale hiding (defaultTimeLocale)
import System.IO.Unsafe
import System.IO
import Test.QuickCheck
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
instance Show Move where
show :: Move -> String
show Move
Rock = String
"r"
show Move
Paper = String
"p"
show Move
Scissors = String
"s"
instance Arbitrary Move where
arbitrary :: Gen Move
arbitrary = [Move] -> Gen Move
forall a. HasCallStack => [a] -> Gen a
elements [Move
Rock, Move
Paper, Move
Scissors]
convertToMove :: Integer -> Move
convertToMove :: Integer -> Move
convertToMove Integer
0 = Move
Rock
convertToMove Integer
1 = Move
Paper
convertToMove Integer
2 = Move
Scissors
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 :: Move -> Move -> Integer
outcome :: Move -> Move -> Integer
outcome = Move -> Move -> Integer
outcome
tournamentOutcome :: Tournament -> Integer
tournamentOutcome :: Tournament -> Integer
tournamentOutcome = Tournament -> Integer
tournamentOutcome
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
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
type Strategy = [Move] -> 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
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 :: 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
sLostLast :: Move -> Strategy
sLostLast :: Move -> Strategy
sLostLast Move
move = Strategy
rock
echo :: Move -> Strategy
echo :: Move -> Strategy
echo Move
start [Move]
moves
= case [Move]
moves of
[] -> Move
start
(Move
last:[Move]
_) -> Move
last
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
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)
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
helloWorld :: IO ()
helloWorld :: IO ()
helloWorld = String -> IO ()
putStr String
"Hello, World!"
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
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
read2lines :: IO ()
read2lines :: IO ()
read2lines
= do IO String
getLine
IO String
getLine
String -> IO ()
putStrLn String
"Two lines read."
getNput :: IO ()
getNput :: IO ()
getNput = do String
line <- IO String
getLine
String -> IO ()
putStrLn String
line
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)
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
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)
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)
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)
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
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
type Tournament = ([Move],[Move])
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
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"
play :: Strategy -> IO ()
play :: Strategy -> IO ()
play Strategy
strategy =
Strategy -> Tournament -> IO ()
playInteractive Strategy
strategy ([],[])
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)
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!")
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)