PGN.hs

module Macbeth.Utils.PGN (
  saveAsPGN
) where

import Macbeth.Fics.Configuration
import Macbeth.Fics.Api.Api
import Macbeth.Fics.Api.Move
import Macbeth.Fics.Api.Game (GameResult)
import qualified Macbeth.Utils.FEN as FEN
import Macbeth.Wx.BoardState

import Control.Monad
import Data.Maybe
import Data.Time
import System.FilePath


saveAsPGN :: BoardState ->  IO ()
saveAsPGN b = saveAsPGN' (reverse $ moves b) (gameResult b)

saveAsPGN' :: [Move] -> Maybe GameResult -> IO ()
saveAsPGN' [] _ = return ()
saveAsPGN' moves mGameResult = do
  dateTime <- getZonedTime
  appDir <- directory `fmap` loadConfig
  when (isJust appDir) $ do
    path <- filepath (fromJust appDir) dateTime (head moves)
    appendFile path $ toPGN (filter (isJust . movePretty) moves) mGameResult dateTime

filepath :: FilePath -> ZonedTime -> Move -> IO FilePath
filepath appDir dateTime m = return $ appDir </>
  formatTime Data.Time.defaultTimeLocale "%Y-%m-%d_%H-%M-%S_" dateTime ++ nameW m ++ "_vs_" ++ nameB m ++ ".pgn"

toPGN :: [Move] -> Maybe GameResult -> ZonedTime -> String
toPGN [] _ _ = ""
toPGN moves@(m:_) mGameResult dateTime =
  tagsSection m mGameResult dateTime ++ "\n\n" ++
  moveSection (if FEN.available $ head moves then tail moves else moves) ++
  " " ++ maybe "" show mGameResult ++ "\n\n"

moveSection :: [Move] -> String
moveSection = unwords . fmap (toString . toSAN)

tagsSection :: Move -> Maybe GameResult -> ZonedTime -> String
tagsSection m mGameResult dateTime =
  "[Event \"?\"]\n\
  \[Site \"?\"]\n\
  \[Date \"" ++ formatTime Data.Time.defaultTimeLocale "%Y.%m.%d" dateTime ++ "\"]\n\
  \[Time \"" ++ formatTime Data.Time.defaultTimeLocale "%T" dateTime ++ "\"]\n\
  \[Round \"?\"]\n\
  \[White \"" ++ nameW m ++ "\"]\n\
  \[Black \"" ++ nameB m ++ "\"]\n\
  \[Result \"" ++ maybe "?" show mGameResult ++ "\"]\n\
  \[BlackElo \"?\"]\n\
  \[WhiteElo \"?\"]\n\
  \[ECO \"?\"]\n\
  \[TimeControl \"?\"]\n\
  \[SetUp \"" ++ (if FEN.available m then "1" else "?") ++ "\"]\n\
  \[FEN \"" ++ (if FEN.available m then FEN.convert m else "?") ++ "\"]\n"

toSAN :: Move -> (Int, PColor, String)
toSAN m = (moveNumber m, turn m, fromJust $ movePretty m)

toString :: (Int, PColor, String) -> String
toString (num, Black, move) = show num ++ "." ++ move
toString (_, White, move) = move