htzaar-0.0.2: src/Play.hs

module Play
  ( play
  ) where

import Control.Monad
import Data.Function
import Data.List
import Data.Maybe
import Data.Word
import Graphics.Rendering.OpenGL
import Graphics.UI.SDL hiding (init, Color)
import qualified Graphics.UI.SDL as SDL
import System.Random

import Board hiding (Position)
import qualified Board as B

data State = State
  { bt      :: BoardTree
  , history :: [State]
  , stdGen  :: StdGen
  , ai      :: AI
  , stage   :: Stage
  }

data Stage
  = A
  | B  B.Position
  | C Move
  | D Move B.Position
  | E


initState g ai = State
  { bt      = boardTree startingBoard
  , history = []
  , stdGen  = g
  , ai      = ai
  , stage   = A
  }

play :: StdGen -> AI -> IO ()
play g ai = do
  SDL.init [InitVideo]
  setCaption "htzaar" "htzaar"
  glSetAttribute glRedSize   8
  glSetAttribute glGreenSize 8
  glSetAttribute glBlueSize  8
  glSetAttribute glAlphaSize 8
  glSetAttribute glDepthSize 24
  glSetAttribute glDoubleBuffer 1
  setView 600 400
  cullFace  $= Nothing

  clearColor $= Color4 (255/255) (246/255) (143/255) 0
  clearDepth $= 1
  depthMask  $= Disabled
  loop $ initState g ai
  quit

setView :: Int -> Int -> IO ()
setView w h = do
  setVideoMode w h 16 [OpenGL, Resizable] >> return ()
  matrixMode $= Projection
  loadIdentity
  let r = (fromIntegral w / fromIntegral h)
  ortho (-r) r (-1) 1 (-1) 1
  matrixMode $= Modelview 0
  viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))

redraw :: State -> IO ()
redraw state = do
  clear [ColorBuffer, DepthBuffer] 
  loadIdentity
  scale3 0.2 0.2 1
  grid
  case stage state of
    A     -> pieces board
    B p   -> highlightPosition p >> pieces board
    C m   -> pieces $ applyMove board m
    D m p -> highlightPosition p >> pieces (applyMove board m)
    E     -> pieces board
  flush
  glSwapBuffers
  where
  BoardTree _ board _ = bt state



loop :: State -> IO ()
loop state = do
  event <- pollEvent
  state <- handler event state
  when (event /= Quit) $ loop state

handler :: Event -> State -> IO State
handler event state = case event of
  NoEvent         -> return state
  VideoExpose     -> redraw state >> return state
  VideoResize x y -> setView x y >> return state
  MouseButtonDown x y ButtonLeft -> do
    r <- clickPosition x y
    s <- userSelectedPosition r state
    redraw s
    return s
  MouseButtonDown _ _ ButtonRight -> case history state of
    []    -> return state
    (a:_) -> redraw a >> return a
  KeyDown (key) | symKey key == SDLK_SPACE -> do
    s <- userSelectedPass state
    redraw s
    return s
  _ -> return state

mousePosition :: Word16 -> Word16 -> IO (Float, Float)
mousePosition x y = do
    mm <- get $ matrix $ Just $ Modelview 0
    pm <- get $ matrix $ Just Projection
    vp <- get $ viewport
    Vertex3 x y _ <- unProject (Vertex3 (fromIntegral x) (fromIntegral y) 0) (mm :: GLmatrix GLdouble) (pm :: GLmatrix GLdouble) vp
    return (realToFrac x, realToFrac (-y))

clickPosition :: Word16 -> Word16 -> IO (Maybe B.Position)
clickPosition x y = do
  (x, y) <- mousePosition x y
  let (p, d) = minimumBy (compare `on` snd) [ (p, sqrt ((x - x') ^^ 2 + (y - y') ^^ 2)) | (p, (x', y')) <- boardPositions ]
  return (if d < 0.4 then Just p else Nothing)

userSelectedPosition :: Maybe B.Position -> State -> IO State
userSelectedPosition Nothing  s = case stage s of
  E -> newGame s
  _ -> return s
userSelectedPosition (Just p) s = case stage s of
  A      | or  [ True | ((a, _), _)      <- turns, a == p           ] -> return s { history = s : history s, stage = B p       }
  B p1   | all (\ (_, a) -> a == Nothing) turns                       -> applyTurn ((p1, p), Nothing) s
         | or  [ True | (a, _)           <- turns, a == (p1, p)     ] -> return s { history = s : history s, stage = C (p1, p) }
  C m    | or  [ True | (a, Just (b, _)) <- turns, a == m, b == p   ] -> return s { history = s : history s, stage = D m p     } 
  D m p1 | elem t turns                                               -> applyTurn t s
    where
    t = (m, Just (p1, p))
  E -> newGame s
  _ -> return s
  where
  BoardTree _ _ branches = bt s
  turns = fst $ unzip branches

userSelectedPass :: State -> IO State
userSelectedPass s = case stage s of
  C m | elem (m, Nothing) turns -> applyTurn (m, Nothing) s
  _ -> return s
  where
  BoardTree _ _ branches = bt s
  turns = fst $ unzip branches

applyTurn :: Turn -> State -> IO State
applyTurn t s
  | null branches' = do
    putStrLn $ "white : " ++ showTurn t
    putStrLn "White Wins!"
    return s { history = s : history s, stage = E, bt = swapBoardTree bt', stdGen = g }
  | otherwise      = do
    putStrLn $ "white : " ++ showTurn t
    putStrLn $ "black : " ++ showTurn t'
    if null branches''
      then do
        putStrLn "Black Wins!"
        return s { history = s : history s, stage = E, bt = bt'', stdGen = g }
      else do
        return s { history = s : history s, stage = A, bt = bt'', stdGen = g }
  where
  BoardTree _ _ branches = bt s
  bt'@(BoardTree _ _ branches') = swapBoardTree $ fromJust $ lookup t branches
  (t', g) = strategy (ai s) bt' (stdGen s)
  bt''@(BoardTree _ _ branches'') = swapBoardTree $ case lookup t' branches' of
    Nothing -> error $ "Invalid AI Turn: " ++ show t'
    Just a -> a

newGame :: State -> IO State
newGame s = do
  putStrLn "New Game!"
  return (initState (stdGen s) (ai s)) { history = s : history s }

grid :: IO ()
grid = do
  color3 (128/255) (128/255) (128/255)
  renderPrimitive Polygon $ do
    p A1
    p A5
    p E8
    p I5
    p I1
    p E1
  lineWidth $= 3
  preservingMatrix $ do
    color3  0.1 0.1 0.1
    g
    rotate3 (pi / 3) 0 0 1 >> g
    rotate3 (pi / 3) 0 0 1 >> g
    rotate3 (pi / 3) 0 0 1 >> g
    rotate3 (pi / 3) 0 0 1 >> g
    rotate3 (pi / 3) 0 0 1 >> g
  where
  p a = vertex2 x y where (x, y) = boardPosition a
  g = renderPrimitive Lines $ do
    p E5 >> p E8
    p F1 >> p F8
    p G1 >> p G7
    p H1 >> p H6
    p I1 >> p I5

highlightPosition :: B.Position -> IO ()
highlightPosition p = preservingMatrix $ do
    translate3 x y 0
    color3 0 0 1
    lineWidth $= 2
    ring 0.4
    where
    (x, y) = boardPosition p
  
data PieceColor = White | Black

pieces :: Board -> IO ()
pieces (whites, blacks) = do
  mapM_ (piece White) whites
  mapM_ (piece Black) blacks

piece :: PieceColor -> (B.Position, Type, Int) -> IO ()
piece c (p, t, size) = preservingMatrix $ do
  translate3 x y 0
  scale3 0.3 0.3 1
  lineWidth $= 1
  stack size
  where
  (x, y) = boardPosition p
  (chipColor, lineColor, crownColor) = case c of
    White -> (color3 1 1 1, color3 0 0 0, color3 ( 60/255) ( 60/255) (  0/255))
    Black -> (color3 0 0 0, color3 1 1 1, color3 (255/255) (215/255) (  0/255))
  stack 0 = case t of
    Tott   -> return ()
    Tzarra -> crownColor >> disc 0.25
    Tzaar  -> crownColor >> disc 0.75 >> chipColor >> disc 0.5 >> crownColor >> disc 0.25
  stack n = do
    chipColor >> disc 1
    lineColor >> ring 1
    when (n /= 1) $ translate3 0 0.2 0
    stack $ n - 1

segments :: [Float]
segments = [0, 2 * pi / 24 .. 2 * pi] ++ [0]

disc :: Float -> IO ()
disc a = renderPrimitive TriangleFan $ vertex2 0 0 >> mapM_ (\ p -> vertex2 (a * cos p) (a * sin p)) segments

ring :: Float -> IO ()
ring a = renderPrimitive LineStrip $ mapM_ (\ p -> vertex2 (a * cos p) (a * sin p)) segments


boardPosition :: B.Position -> (Float, Float)
boardPosition a = fromJust $ lookup a boardPositions

boardPositions :: [(B.Position, (Float, Float))]
boardPositions =
  [ (A1, p (-4) (-2))
  , (A2, p (-4) (-1))
  , (A3, p (-4) ( 0))
  , (A4, p (-4) ( 1))
  , (A5, p (-4) ( 2))
  , (B1, p (-3) (-3))
  , (B2, p (-3) (-2))
  , (B3, p (-3) (-1))
  , (B4, p (-3) ( 1))
  , (B5, p (-3) ( 2))
  , (B6, p (-3) ( 3))
  , (C1, p (-2) (-3))
  , (C2, p (-2) (-2))
  , (C3, p (-2) (-1))
  , (C4, p (-2) ( 0))
  , (C5, p (-2) ( 1))
  , (C6, p (-2) ( 2))
  , (C7, p (-2) ( 3))
  , (D1, p (-1) (-4))
  , (D2, p (-1) (-3))
  , (D3, p (-1) (-2))
  , (D4, p (-1) (-1))
  , (D5, p (-1) ( 1))
  , (D6, p (-1) ( 2))
  , (D7, p (-1) ( 3))
  , (D8, p (-1) ( 4))
  , (E1, p ( 0) (-4))
  , (E2, p ( 0) (-3))
  , (E3, p ( 0) (-2))
  , (E4, p ( 0) (-1))
  , (E5, p ( 0) ( 1))
  , (E6, p ( 0) ( 2))
  , (E7, p ( 0) ( 3))
  , (E8, p ( 0) ( 4))
  , (F1, p ( 1) (-4))
  , (F2, p ( 1) (-3))
  , (F3, p ( 1) (-2))
  , (F4, p ( 1) (-1))
  , (F5, p ( 1) ( 1))
  , (F6, p ( 1) ( 2))
  , (F7, p ( 1) ( 3))
  , (F8, p ( 1) ( 4))
  , (G1, p ( 2) (-3))
  , (G2, p ( 2) (-2))
  , (G3, p ( 2) (-1))
  , (G4, p ( 2) ( 0))
  , (G5, p ( 2) ( 1))
  , (G6, p ( 2) ( 2))
  , (G7, p ( 2) ( 3))
  , (H1, p ( 3) (-3))
  , (H2, p ( 3) (-2))
  , (H3, p ( 3) (-1))
  , (H4, p ( 3) ( 1))
  , (H5, p ( 3) ( 2))
  , (H6, p ( 3) ( 3))
  , (I1, p ( 4) (-2))
  , (I2, p ( 4) (-1))
  , (I3, p ( 4) ( 0))
  , (I4, p ( 4) ( 1))
  , (I5, p ( 4) ( 2))
  ]
  where
  p :: Int -> Int -> (Float, Float)
  p x y = (x', y')
    where
    x' = fromIntegral x * sin (pi / 3)
    y' | even x    = fromIntegral y
       | otherwise = fromIntegral y - (fromIntegral (signum y) * 0.5)



--vertex3 :: Real a => a -> a -> a -> IO ()
vertex2 x y = vertex $ Vertex3 (toFloat x) (toFloat y) 0

--color3 :: Real a => a -> a -> a -> IO ()
color3 r g b = color $ Color3 (toFloat r) (toFloat g) (toFloat b)

--scale3 :: Real a => a -> a -> a -> IO ()
scale3 x y z = scale (toFloat x) (toFloat y) (toFloat z)

--translate3 :: Real a => a -> a -> a -> IO ()
translate3 x y z = translate $ Vector3 (toFloat x) (toFloat y) (toFloat z)

--rotate3 :: (Real a, Floating a) => a -> a -> a -> a -> IO ()
rotate3 angle x y z = rotate (toFloat $ angle * 180 / pi) $ Vector3 (toFloat x) (toFloat y) (toFloat z)

toFloat :: (Real a, Floating a) => a -> GLfloat
toFloat = realToFrac