-----------------------------------------------------------------------
--  Haskell: The Craft of Functional Programming
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2010.
-- 
--  RPS: Rock - Paper - Scissors
-----------------------------------------------------------------------

module RPS 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
Rock Move
Rock = Integer
0
outcome Move
Rock Move
Paper = -Integer
1
outcome Move
Rock Move
Scissors = Integer
1
outcome Move
Paper Move
Rock = Integer
1
outcome Move
Paper Move
Paper = Integer
0
outcome Move
Paper Move
Scissors = -Integer
1
outcome Move
Scissors Move
Rock = -Integer
1
outcome Move
Scissors Move
Paper = Integer
1
outcome Move
Scissors Move
Scissors = Integer
0

-- 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

random :: Strategy
random :: Strategy
random [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

-- 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

-- Echo a move that would have lost the last play; 
-- also have to supply starting Move.

sLostLast :: Move -> Strategy
sLostLast Move
start [Move]
moves 
      = case [Move]
moves of
          [] -> Move
start
          (Move
last:[Move]
_) -> Move -> Move
lose 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

alternate :: Strategy -> Strategy -> Strategy

alternate :: Strategy -> Strategy -> Strategy
alternate Strategy
str1 Strategy
str2 [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
2 of
      Int
1 -> Strategy
str1 [Move]
moves
      Int
0 -> Strategy
str2 [Move]
moves

alternate2 :: Strategy -> Strategy -> Strategy

alternate2 :: Strategy -> Strategy -> Strategy
alternate2 Strategy
str1 Strategy
str2 = 
    \[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
2 of
          Int
1 -> Strategy
str1 [Move]
moves
          Int
0 -> Strategy
str2 [Move]
moves

alternate3 :: Strategy -> Strategy -> Strategy

alternate3 :: Strategy -> Strategy -> Strategy
alternate3 Strategy
str1 Strategy
str2 [Move]
moves = 
    (Strategy -> Move) -> [Strategy] -> [Move]
forall a b. (a -> b) -> [a] -> [b]
map (Strategy -> Strategy
forall a b. (a -> b) -> a -> b
$ [Move]
moves) [Strategy
str1,Strategy
str2] [Move] -> Int -> Move
forall a. HasCallStack => [a] -> Int -> a
!! ([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
2) 

beatStrategy :: Strategy -> Strategy

beatStrategy :: Strategy -> Strategy
beatStrategy Strategy
opponent [Move]
moves =
    Move -> Move
beat (Strategy
opponent [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 


--
-- 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
     = if Integer
nInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<=Integer
0 then ([],[]) else Strategy -> Strategy -> Tournament -> Tournament
step Strategy
strategyA Strategy
strategyB (Strategy -> Strategy -> Integer -> Tournament
playSvsS Strategy
strategyA Strategy
strategyB (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1))


--
-- 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
random
            Integer
4 -> Strategy -> Strategy -> Strategy
sToss Strategy
random (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
random)