module Main where

import Control.Monad

import Data.Array
import Data.Maybe
import Data.IORef

import Graphics.UI.Gtk hiding (fill)
import Graphics.UI.Gtk.Glade
import Graphics.Rendering.Cairo
import Graphics.Rendering.Cairo.SVG

import System.IO
import System.Gnome.GConf

import Text.ParserCombinators.Parsec (parseFromFile)

import PGN
import Piece
import Util

data Move = Move !Square !Square

data Square = Square !File !Rank
  deriving (Eq,Ord,Ix)

data Rank = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8
  deriving (Eq,Ord,Enum,Ix)

data File = A | B | C | D | E | F | G | H
  deriving (Eq,Ord,Enum,Ix)

instance Show File where
  showsPrec _ f = (fileToChar f :)
    where
      fileToChar A = 'a'
      fileToChar B = 'b'
      fileToChar C = 'c'
      fileToChar D = 'd'
      fileToChar E = 'e'
      fileToChar F = 'f'
      fileToChar G = 'g'
      fileToChar H = 'h'

instance Show Rank where
  showsPrec _ r = (rankToChar r :)
    where
      rankToChar R1 = '1'
      rankToChar R2 = '2'
      rankToChar R3 = '3'
      rankToChar R4 = '4'
      rankToChar R5 = '5'
      rankToChar R6 = '6'
      rankToChar R7 = '7'
      rankToChar R8 = '8'

instance Show Square where
  showsPrec _ (Square f r) = shows f . shows r

instance Show Move where
  showsPrec _ (Move a b) = shows a . shows b

data GameState = GameState {
                   boardPieces    :: Array Square (Maybe Piece),
                   piecesSVG      :: Array Piece SVG,
                   boardSVG       :: SVG,
                   selectedSquare :: Maybe Square
                 }

-- Initial pieces position.
initialPos :: [(Square,Piece)]
initialPos =
  -- Black pieces.
  [ (Square A R8, Piece Black Rook),   (Square B R8, Piece Black Knight),
    (Square C R8, Piece Black Bishop), (Square D R8, Piece Black Queen),
    (Square E R8, Piece Black King),   (Square F R8, Piece Black Bishop),
    (Square G R8, Piece Black Knight), (Square H R8, Piece Black Rook) ] ++
  [ (Square x R7, Piece Black Pawn) | x <- [A .. H] ] ++
  -- White pieces.
  [ (Square x R2, Piece White Pawn) | x <- [A .. H] ] ++
  [ (Square A R1, Piece White Rook),   (Square B R1, Piece White Knight),
    (Square C R1, Piece White Bishop), (Square D R1, Piece White Queen),
    (Square E R1, Piece White King),   (Square F R1, Piece White Bishop),
    (Square G R1, Piece White Knight), (Square H R1, Piece White Rook) ]

setupMenuHandlers :: GladeXML -> GConf -> Window -> IO ()
setupMenuHandlers xml gconf win = do
  fileMenuQuit <- xmlGetWidget xml castToMenuItem "fileMenuQuit"
  fileMenuQuit `onActivateLeaf` mainQuit
    
  fileMenuOpen <- xmlGetWidget xml castToMenuItem "fileMenuOpen"
  fileMenuOpen `onActivateLeaf` do
    fileOpenDialog <- fileChooserDialogNew (Just "Open Game") (Just win)
                        FileChooserActionOpen
                        [(stockCancel, ResponseCancel),
                         (stockOpen, ResponseAccept)]
    ffilter <- fileFilterNew
    fileFilterSetName ffilter "PGN files"
    fileFilterAddPattern ffilter "*.[pP][gG][nN]"
    fileChooserAddFilter fileOpenDialog ffilter
    response <- dialogRun fileOpenDialog
    when (response == ResponseAccept) $ do
      file <- liftM fromJust (fileChooserGetFilename fileOpenDialog)
      result <- parseFromFile pgnParser file
      case result of
        Left err -> putStr "Parse error at " >> print err
        Right x  -> print x
    widgetDestroy fileOpenDialog

  editMenuPrefs <- xmlGetWidget xml castToMenuItem "editMenuPrefs"
  editMenuPrefs `onActivateLeaf` do
    colorDialog <- colorSelectionDialogNew "Choose Background Color"
    colorSel    <- colorSelectionDialogGetColor colorDialog
    old         <- gconfGet gconf gconfBgColorKey
    windowSetTransientFor colorDialog win
    colorSelectionSetCurrentColor colorSel (stringToColor old)
    response <- dialogRun colorDialog
    when (response == ResponseOk) $ do
      color <- colorSelectionGetCurrentColor colorSel
      gconfSet gconf gconfBgColorKey (colorToString color)
    widgetDestroy colorDialog

  helpMenuAbout <- xmlGetWidget xml castToMenuItem "helpMenuAbout"
  helpMenuAbout `onActivateLeaf` do
    aboutDialog <- xmlGetWidget xml castToAboutDialog "aboutDialog"
    dialogRun aboutDialog
    widgetHide aboutDialog
  return ()

-- GConf keys
gconfAppPath :: String
gconfAppPath = "/apps/LambdaChess"

gconfBgColorKey :: String
gconfBgColorKey = gconfAppPath ++ "/background_color"

-- Render the background.
renderBackground :: Color -> Render ()
renderBackground c = let (r,g,b) = colorToCairo c in setSourceRGB r g b >> paint

-- Render all the given pieces on the board.
renderPieces ::
  Array Square (Maybe Piece) -> Array Piece SVG -> Double -> Render ()
renderPieces pieces svgs squareSize = do
  forM_ (assocs pieces) $ \(Square f r, mp) -> do
    whenJust mp $ \piece -> do
      let pieceSVG        = svgs ! piece
          (width, height) = mapPair fromIntegral (svgGetSize pieceSVG)
      save
      translate (squareSize * enumToNum f) (squareSize * (7 - enumToNum r))
      scale (squareSize / width) (squareSize / height)
      svgRender pieceSVG
      restore

--movePiece :: Array Square (Maybe Piece) -> Move -> Array Square (Maybe Piece)

initState :: IO (IORef GameState)
initState = do
  -- Load SVG files for the board and the pieces.
  svgBoard     <- svgNewFromFile "board.svg"
  pieces       <- loadPieces

  let board = map (\(a,b) -> (a,Just b)) initialPos ++
        [ (Square x y,  Nothing) | x <- [A .. H], y <- [R3 .. R6] ]
  -- Setup initial state
  newIORef GameState {
    boardPieces    = array (Square A R1, Square H R8) board,
    piecesSVG      = pieces,
    boardSVG       = svgBoard,
    selectedSquare = Nothing
  }

setupBoard :: GladeXML -> GConf -> IO ()
setupBoard xml gconf = do
  drawingArea  <- xmlGetWidget xml castToDrawingArea "drawingArea"

  -- Setup initial state
  stateRef <- initState

  -- State wrapper functions.
  -- We liftIO readIORef in evalState because we use it in the Render monad.
  let evalState action = liftIO (readIORef stateRef) >>= action
      updateState f    = modifyIORef stateRef f

  -- Redraw the board when the background color changes.
  gconfAddDir gconf gconfAppPath
  gconfNotifyAdd gconf gconfBgColorKey
    (\_ (_ :: String) -> widgetQueueDraw drawingArea)

  drawingArea `onExpose` \Expose { eventRegion = exposeRegion } -> do
    color                   <- gconfGet gconf gconfBgColorKey
    drawWindow              <- widgetGetDrawWindow drawingArea
    (drawWidth, drawHeight) <- liftM (mapPair fromIntegral) $
                                   widgetGetSize drawingArea

    renderWithDrawable drawWindow $ do
      evalState $ \GameState {
                    boardPieces    = pieces,
                    boardSVG       = board,
                    selectedSquare = square,
                    piecesSVG      = svgPieces
                  } -> do
        let (boardWidth, boardHeight) = mapPair fromIntegral $ svgGetSize board
            sideSize   = min drawWidth drawHeight - 10
            squareSize = sideSize / 8
            xoffset    = (drawWidth - sideSize) / 2
            yoffset    = (drawHeight - sideSize) / 2
        region exposeRegion
        clip

        renderBackground (stringToColor color)
        -- Center the board in the drawing area.
        translate xoffset yoffset
        -- Scale the board so that it is the biggest square fitting the area.
        save
        scale (sideSize / boardWidth) (sideSize / boardHeight)
        svgRender board
        restore
        -- Highlight selected square if needed.
        whenJust square $ \(Square f r) -> do
          setSourceRGBA 0 0 1 0.65
          rectangle (squareSize * enumToNum f) (squareSize * (7 - enumToNum r))
                    squareSize squareSize
          fill
        -- Render the pieces.
        renderPieces pieces svgPieces squareSize
    return True

  -- Catch mouse clicks in the drawing area.
  drawingArea `onButtonPress` \Button {
                                eventButton = button,
                                eventClick = click,
                                eventX = x,
                                eventY = y
                              } -> do
    case (button,click) of
      (LeftButton,SingleClick) -> do
        -- FIXME huge copy-paste.
        (drawWidth, drawHeight) <- liftM (mapPair fromIntegral) $
                                   widgetGetSize drawingArea
        let sideSize   = min drawWidth drawHeight - 10
            squareSize = sideSize / 8
            xoffset    = (drawWidth - sideSize) / 2
            yoffset    = (drawHeight - sideSize) / 2
        when (x >= xoffset && x < xoffset + sideSize &&
              y >= yoffset && y < yoffset + sideSize) $ do
          let colx   = floor ((x - xoffset) / squareSize)
              rowy   = floor ((y - yoffset) / squareSize)
              square = Square (toEnum colx) (toEnum (7 - rowy))
              new    = Just square
          updateState $ \state ->
            if selectedSquare state == new
              then state { selectedSquare = Nothing }
              else state { selectedSquare = new }
          widgetQueueDraw drawingArea
        return True
      _ -> return False
  return ()

main :: IO ()
main = do
  initGUI
  Just xml <- xmlNew "lambdachess.glade"
  window   <- xmlGetWidget xml castToWindow "gameWindow"
  gconf    <- gconfGetDefault
  window `onDestroy` mainQuit
  setupMenuHandlers xml gconf window
  setupBoard xml gconf
  widgetShowAll window
  mainGUI