
-----------
-- Halma --
-----------

module Halma (Halma, halma) where

import Game
import Data.Array
-- import Graphics.UI.WX
import Graphics.UI.WX     hiding (border, empty, point)
import Graphics.UI.WXCore hiding (empty, point)
import Tools

data Halma = Halma (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)

type HalmaMove = ((Int, Int), (Int, Int))

halma :: Halma
halma = undefined

instance Game Halma where

  name _ = "halma"

  standard _ = Properties    { players = 2, boardsize = 8, human = [True, False, False, False, False, False] }
  possible _ = PropertyRange { playersrange = [2, 3, 4, 6], boardsizerange = [8] }

  new pr = let empty = [((x, y), Nothing) | x <- [-8 .. 8], y <- [-8 .. 8]]
           in Halma $ array ((-8, -8), (8, 8)) empty // concatMap (\p -> map (\t -> (t, Just p)) $ startpos $ pos pr p) [0 .. players pr - 1]
  
  moves pr p (Halma s) = map (move pr) (allMoves pr p s)

  showmove pr p (Halma s) i = let ((x1, y1), (x2, y2)) = allMoves pr p s !! i
                              in "abcdefghijklmnopq" !! (x1 + 8) : show (9 - y1) ++ "-" ++ "abcdefghijklmnopq" !! (x2 + 8) : show (9 - y2)
  
  value pr p (Halma st) | null $ allMoves pr p st = let winners = map snd $ filter (\(d, _) -> d == 20) $ zip totaldists [0..]
                                                    in foldr ($) (replicate (players pr) (-1)) $ map (|> 1) winners
                        | otherwise               = map myvalue [0 .. players pr - 1]
    where
      totaldists :: [Int]
      totaldists = map totaldist [0 .. players pr - 1]

      totaldist :: Player -> Int
      totaldist p' = let mypieces = map (\(i, _e) -> i) $ filter (\(_i, e) -> e == Just p') $ assocs st
                     in sum $ map (dist pr p') mypieces

      myvalue :: Player -> Float
      myvalue p' = let d = sum (map totaldist [0 .. players pr - 1]) - (players pr) * totaldist p'
                   in (fromInteger . toInteger) d  / (fromInteger . toInteger) (120 * (players pr))

  board p pr vart _ia move' = do

    marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY
    varg   <- varCreate $ grate rectZero 0 (0, 0) sizeZero
    vare   <- varCreate (Nothing :: Maybe (Int, Int))

    let 
    
      onpaint :: DC () -> Rect -> IO ()
      onpaint dc r = do
        t <- varGet vart
        e <- varGet vare
        b_ <- border dc (16, 16)
        let g_ = grate r b_ (26, 17) (Size 4 7)
        b <- fit dc (16, 16) $ rectWidth (field g_ (0, 0))
        let Halma st = state t
            g = grate r b (26, 17) (Size 4 7)
            radius = rectHeight (field g (0, 0)) `div` 3
            lin' :: Rect -> Rect -> IO ()
            lin' (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = do
              line dc (pt (x1 + w1) (y1 + h1 `div` 2)) (pt (x2 + w2) (y2 + h2 `div` 2)) []
            lin :: (Int, Int) -> (Int, Int) -> IO ()
            lin p' q = lin' (field g $ tograte p') (field g $ tograte q)
        varSet varg g
        tileBitmap dc r marble
--{        drawGrate dc g [penColor := yellow]
        for 0 16 (\j -> do
          let i = head $ dropWhile (\i' -> inside $ fromgrate (i', j)) [13 ..]
          drawTextRect dc (show $ 17 - j) $ field g ( i - 1, j) |#| field g (     i, j)
          drawTextRect dc (show $ 17 - j) $ field g (25 - i, j) |#| field g (26 - i, j)
          let d  = (i  - 1 + 3 * j) `div` 2 - 18
              e' = (25 - i + 3 * j) `div` 2 - 18
          drawTextRect dc [['A' ..] !! (16 - j)] $ field g (i  - 1 - d, j - d) |#| field g (i  - 1 - d, j - 1 - d)
          drawTextRect dc [['A' ..] !! (16 - j)] $ field g (25 - i - e', j - e') |#| field g (25 - i - e', j - 1 - e')
          )
        for 0 4 (\n -> do
          lin (  - 4,  n - 8) (n - 4,  n - 8)
          lin (n - 8,  n - 4) (    4,  n - 4)
          lin (  - 4,  n    ) (n + 4,  n    )
          lin (n    ,  n + 4) (    4,  n + 4)
          lin (n - 8,    - 4) (n - 8,  n - 4)
          lin (n - 4,  n - 8) (n - 4,      4)
          lin (n    ,    - 4) (n    ,  n + 4)
          lin (n + 4,  n    ) (n + 4,      4)
          lin (  - 4, -n + 4) (n - 4,      4)
          lin (n - 8,    - 4) (    4, -n + 8)
          lin (  - 4, -n - 4) (n + 4,      4)
          lin (n    ,    - 4) (    4, -n    )
          )
        for 0 24 (\i -> for 0 16 (\j ->
          when (even (i + j)) $ when (inside $ fromgrate (i, j)) $
            drawPiece dc (field g (i, j)) radius (st ! fromgrate (i, j))
                   ) )
        case e of Just p' -> drawBrightPiece dc (field g $ tograte p') radius
                  Nothing -> return ()
         
      onclick :: Point -> IO ()
      onclick point = do 
        t <- varGet vart
        e <- varGet vare
        g <- varGet varg
        let Halma st = state t
            n = fromgrate $ locate g point 
        case (e, inside n) of
          (Nothing, True ) -> when (st ! n == Just (player t)) $ varSet vare (Just n) >> repaint p
          (_      , False) -> varSet vare Nothing >> repaint p
          (Just te, True ) -> case lookup (te, n) $ zip (allMoves pr (player t) st) [0..] of
            Nothing -> varSet vare Nothing >> repaint p
            Just  i -> varSet vare Nothing >> repaint p >> move' i

    set p [ on click    := onclick
          , on unclick  := onclick
          , on paint    := onpaint
          , on resize  ::= repaint
          ]

    return ()

fit :: DC () -> (Int, Int) -> Int -> IO Int
fit dc t m = do
  s <- get dc fontSize
  fit_ dc (s + 6)
 where
  fit_ :: DC () -> Int -> IO Int
  fit_ _dc 1 = border dc t
  fit_ dc' s = do
    set dc' [fontSize := s - 1]
    b <- border dc t
    if b <= m then return b
              else fit_ dc' (s - 1)

drawPiece :: DC () -> Rect -> Int -> Maybe Player -> IO ()
drawPiece dc (Rect x y w h) r mp = circle dc (pt (x + w) (y + h `div` 2)) r [brushColor := col mp]

drawBrightPiece :: DC () -> Rect -> Int -> IO ()
drawBrightPiece dc (Rect x y w h) r = circle dc (pt (x + w) (y + h `div` 2)) r [brushKind := BrushTransparent, penWidth := 3, penColor := yellow]

tograte :: (Int, Int) -> (Int, Int)
tograte (i, j) = (12 + 2 * i - j, 8 + j)

fromgrate :: (Int, Int) -> (Int, Int)
fromgrate (i, j) = (-10 + (i + j) `div` 2, -8 + j)

-- x = ½ (i + j) - 10
-- y = j - 8

col :: Maybe Player -> Color
col p = case p of 
  Nothing -> white
  Just 0  -> blue
  Just 1  -> red
  Just 2  -> green
  Just 3  -> rgb 160 0   (192 :: Int)
  Just 4  -> rgb 192 128 (0 :: Int)
  Just 5  -> grey
  _       -> black

(+-) :: Num a => (a, a) -> (a, a) -> (a, a)
(a, b) +- (c, d) = (a + c, b + d)

allMoves :: Properties -> Player -> Array (Int, Int) (Maybe Player) -> [HalmaMove]
allMoves pr p st | p == 0 && 20 `elem` (map totaldist [0 .. players pr - 1]) = []
                 | otherwise = stepmoves ++ jumpmoves
  where
    mypieces :: Player -> [(Int, Int)]
    mypieces p' = map (\(i, _e) -> i) $ filter (\(_i, e) -> e == Just p') $ assocs st

    stepmoves :: [HalmaMove]
    stepmoves = let potmoves = concatMap (\t -> map (\s -> (t, t +- s)) $ steps pr p) (mypieces p)
                in filter (\(_f, t) -> inside t && st ! t == Nothing) potmoves

    jumpmoves :: [HalmaMove]
    jumpmoves =  concatMap (\t -> map (\s -> (t, s)) $ floodfill t []) (mypieces p)

    floodfill :: (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
    floodfill t fs = let news = map (\j -> t +- j +- j)
                              $ filter (\j -> let u = t +- j +- j
                                              in inside u 
                                              && st ! (t +- j) /= Nothing
                                              && st ! u == Nothing
                                              && not (u `elem` fs)
                                       )
                              $ halfjumps
                     in foldr ($) fs $ map (\u -> floodfill u . (u :)) news
    totaldist :: Player -> Int
    totaldist p' = sum $ map (dist pr p') $ mypieces p'

steps :: Properties -> Player -> [(Int, Int)]
steps pr p = steppos (pos pr p)
  where
    steppos 0 = [( 1,  1), ( 1,  0), ( 0, -1), (-1, -1)]
    steppos 1 = [( 0,  1), ( 1,  1), ( 1,  0), ( 0, -1)]
    steppos 2 = [(-1,  0), ( 0,  1), ( 1,  1), ( 1,  0)]
    steppos 3 = [(-1, -1), (-1,  0), ( 0,  1), ( 1,  1)]
    steppos 4 = [( 0, -1), (-1, -1), (-1,  0), ( 0,  1)]
    steppos 5 = [( 1,  0), ( 0, -1), (-1, -1), (-1,  0)]
    steppos _ = error "steps: Unexpected value"

{-
jumps :: [(Int, Int)]
jumps = map (\(x, y) -> (2 * x, 2 * y)) halfjumps
-}

halfjumps :: [(Int, Int)]
halfjumps = [(1, 1), (1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1)]

dist :: Properties -> Player -> (Int, Int) -> Int
dist pr p t = distpos (pos pr p) t
  where
    distpos 0 (x, y) = 8 - x + y + max 0 (-4 + x    ) + max 0 (-4 - y    )
    distpos 1 (x, y) = 8 - x     + max 0 (-4 + x - y) + max 0 (-4 + y    )
    distpos 2 (x, y) = 8     - y + max 0 (-4 + x    ) + max 0 (-4 + y - x)
    distpos 3 (x, y) = 8 + x - y + max 0 (-4 - x    ) + max 0 (-4 + y    )
    distpos 4 (x, y) = 8 + x     + max 0 (-4 - x + y) + max 0 (-4 - y    )
    distpos 5 (x, y) = 8     + y + max 0 (-4 - x    ) + max 0 (-4 - y + x)
    distpos _ _      = error "dist: Unexpected value"

move :: Properties -> HalmaMove -> (Player, Halma) -> (Player, Halma)
move pr (f, t) (p, Halma s) = ( (p + 1) `mod` players pr
                              , Halma $ s // [(f, Nothing), (t, Just p)]
                              )

startpos :: (Eq t, Num t, Num t1, Enum t1) => t -> [(t1, t1)]
startpos 0 = [(x, y) | x <- [-4 .. -1], y <- [x + 5 ..     4]]
startpos 1 = [(x, y) | x <- [-8 .. -5], y <- [  - 4 .. x + 4]]
startpos 2 = [(x, y) | x <- [-4 .. -1], y <- [x - 4 ..   - 5]]
startpos 3 = [(x, y) | x <- [ 1 ..  4], y <- [  - 4 .. x - 5]]
startpos 4 = [(x, y) | x <- [ 5 ..  8], y <- [x - 4 ..     4]]
startpos 5 = [(x, y) | x <- [ 1 ..  4], y <- [    5 .. x + 4]]
startpos _ = error "startpos: Unexpected value"

pos :: Properties -> Player -> Int
pos pr p | players pr == 2 = [0, 3      ] !! p
         | players pr == 3 = [0, 2, 4   ] !! p
         | players pr == 4 = [0, 1, 3, 4] !! p
         | players pr == 6 = p
         | otherwise       = error "pos: Unexpected value"

inside :: (Int, Int) -> Bool
inside (x, y) = (x >= -4 && y <= 4 && x <= y + 4)
             || (y >= -4 && x <= 4 && y <= x + 4)

{- the halmaboard internally looks like this:

y/j

-8 ....x............
-7 ....xx...........
-6 ....xxx..........
-5 ....xxxx.........
-4 xxxx*****xxxx....
-3 .xxx******xxx....
-2 ..xx*******xx....
-1 ...x********x....
 0 ....*********....
 1 ....x********x...
 2 ....xx*******xx..
 3 ....xxx******xxx.
 4 ....xxxx*****xxxx
 5 .........xxxx....
 6 ..........xxx....
 7 ...........xx....
 8 ............x....

   87654321012345678 x/i
   --------
  
-}
