----------
-- Bamp --
----------

module Bamp (Bamp, bamp) where

import Game
import Array
import Graphics.UI.WX     hiding (border)
import Graphics.UI.WXCore
import Tools

data BampField
  = Empty
  | Portal Player
  | Piece Player
  | Ball
  deriving (Eq, Show)

isPortal :: BampField -> Bool
isPortal (Portal _) = True
isPortal _          = False

isPiece :: BampField -> Bool
isPiece (Piece _) = True
isPiece _         = False

data Bamp = Bamp (Array (Int, Int) BampField) deriving (Eq, Show)

bamp :: Bamp
bamp = undefined

instance Game Bamp where

  name _ = "bamp"

  standard _ = Properties { players = 4, boardsize = 8, human = [True, False, False, False] }

  possible _ = PropertyRange { playersrange = [4], boardsizerange = [6, 8 .. 12] }
  
  new pr = let s = boardsize pr
               h = s `div` 2
           in Bamp $ array ((0, 0), (s - 1, s - 1))
              [((x, y), Empty) | x <- [0 .. s - 1], y <- [0 .. s - 1]]
              // concat [[((0    ,     i), Piece 0), ((    i, 0    ), Piece 0)] | i <- [0 .. h - 1]]
              // concat [[((0    , h + i), Piece 1), ((    i, s - 1), Piece 1)] | i <- [0 .. h - 1]]
              // concat [[((s - 1, h + i), Piece 2), ((h + i, s - 1), Piece 2)] | i <- [0 .. h - 1]]
              // concat [[((s - 1,     i), Piece 3), ((h + i, 0    ), Piece 3)] | i <- [0 .. h - 1]]
              // [((1    , 1    ), Ball    )]
{-{
              // [ ((0    , 0    ), Portal 0)
                 , ((0    , s - 1), Portal 1)
                 , ((s - 1, s - 1), Portal 2)
                 , ((s - 1, 0    ), Portal 3)
                 , ((1    , 1    ), Ball    )
                 ]
}-}  
  moves pr p (Bamp s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s)

  showmove pr p (Bamp s) i = let (x, y) = allMoves (boardsize pr) p s !! i
                             in ['a' ..] !! x : show (boardsize pr - y)
  
  value pr p (Bamp s)
    | null $ moves pr p (Bamp s) = let bsz = boardsize pr
                                   in owner bsz (findBall s) |> 1 $ replicate 4 (-1)
{-{
                                   in case findBall s
                                      of (x, y) | (x, y) == (0      , 0      ) -> [ 1, -1, -1, -1]
                                                | (x, y) == (0      , bsz - 1) -> [-1,  1, -1, -1]
                                                | (x, y) == (bsz - 1, bsz - 1) -> [-1, -1,  1, -1]
                                                | (x, y) == (bsz - 1, 0      ) -> [-1, -1, -1,  1]
                                         _ -> [0, 0, 0, 0]
}-}
    | otherwise = [0, 0, 0, 0]

  board p pr vart ia move = do

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

    let 
    
      onpaint :: DC () -> Rect -> IO ()
      onpaint dc r = do
        return ()
        t <- varGet vart
        let Bamp st = state t
            bsz     = boardsize pr
        b <- border dc (bsz, bsz)
        let g       = grate r b (bsz, bsz) (Size 1 1)
        varSet varg g
        tileBitmap dc r marble
        for 0 (bsz - 1) (\i -> do
          drawTextRect dc [['A' ..] !! i]  $ edge g (i,  -1)
          drawTextRect dc [['A' ..] !! i]  $ edge g (i, bsz)
          drawTextRect dc (show (bsz - i)) $ edge g ( -1, i)
          drawTextRect dc (show (bsz - i)) $ edge g (bsz, i)
          )
        for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->
          drawRect dc (field g (i, j)) [brushKind := BrushTransparent, penColor := setLum 0.2 $ colorplayer $ owner bsz (i, j)]
          ))
        for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->
          drawField dc (field g (i, j)) (st ! (i, j))
          ))

      onclick :: Point -> IO ()
      onclick pt = do 
        t <- varGet vart
        g <- varGet varg
        let Bamp st = state t
            n       = locate g pt
        case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of
          Nothing -> return ()
          Just  i -> move i

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

owner :: Int -> (Int, Int) -> Player
owner bsz (i, j)
  | 2 * i <  bsz && 2 * j <  bsz = 0
  | 2 * i <  bsz && 2 * j >= bsz = 1
  | 2 * i >= bsz && 2 * j >= bsz = 2
  | 2 * i >= bsz && 2 * j <  bsz = 3

drawField :: DC () -> Rect -> BampField -> IO ()
drawField dc (Rect x y w h) Empty      = return ()
drawField dc (Rect x y w h) (Portal p) = circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [penColor := colorplayer p, penWidth := 2, brushKind := BrushTransparent]
drawField dc (Rect x y w h) (Piece  p) = drawRect dc (Rect (x + w `div` 10) (y + h `div` 10) (w - w `div` 5) (h - h `div` 5)) [brushColor := colorplayer p]
drawField dc (Rect x y w h) Ball       = circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) [brushColor := rgb 100 80 40]

allMoves :: Int -> Player -> Array (Int, Int) BampField -> [(Int, Int)]
allMoves bsz p s = filter valid $ filter (\i -> s ! i == Piece p) $ indices s
 where
  (a, b) = findBall s
  valid :: (Int, Int) -> Bool
  valid (x, y) | x /= a && y /= b = False
               | x < a = all (\i -> ok (i, y)) [x + 1 .. a + 1]
               | x > a = all (\i -> ok (i, y)) [a - 1 .. x - 1]
               | y < b = all (\j -> ok (x, j)) [y + 1 .. b + 1]
               | y > b = all (\j -> ok (x, j)) [b - 1 .. y - 1]
  ok :: (Int, Int) -> Bool
  ok t = inRange (bounds s) t
      && case s ! t of Piece _ -> False
                       _       -> True

move :: Int -> (Int, Int) -> (Player, Bamp) -> (Player, Bamp)
move bsz (x, y) (p, Bamp s) = let (a, b) = findBall s
                                  new = follow (a, b) (signum (a - x), signum (b - y))
                              in (owner bsz new, Bamp $ s // [((x, y), Empty), ((a, b), Piece p), (new, Ball)])
 where
  follow :: (Int, Int) -> (Int, Int) -> (Int, Int)
  follow (x, y) (dx, dy)
    | not $ inRange (bounds s) (x + dx, y + dy) = (x, y)
    | s ! (x + dx, y + dy) == Empty             = follow (x + dx, y + dy) (dx, dy)
    | isPortal $ s ! (x + dx, y + dy)           = follow (x + dx, y + dy) (dx, dy)
    | otherwise                                 = (x, y)

findBall :: Array (Int, Int) BampField -> (Int, Int)
findBall s = case dropWhile (not.(== Ball).snd) $ assocs s
             of ((i, Ball):_) -> i
                []            -> (0, 0)

colorplayer :: Int -> Color
colorplayer 0 = hsl 0.66 1   0.5
colorplayer 1 = hsl 0    1   0.5
colorplayer 2 = hsl 0.33 1   0.5
colorplayer 3 = hsl 0.82 1   0.5
colorplayer 4 = hsl 0.11 0.7 0.5
colorplayer 5 = hsl 0    0   0.5
colorplayer _ = hsl 0    0   0