diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,15 @@
+Macbeth - A beautiful FICS client
+Copyright (C) 2016 Tilmann Gass
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public License
+along with this program. If not, see .
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/macbeth-lib.cabal b/macbeth-lib.cabal
new file mode 100644
--- /dev/null
+++ b/macbeth-lib.cabal
@@ -0,0 +1,83 @@
+name: macbeth-lib
+synopsis: Macbeth - A beautiful and minimalistic FICS client
+description: A FICS client written with OSX in mind.
+author: Tilmann Gass
+maintainer: tilmann@macbeth-ficsclient.com
+homepage: http://www.macbeth-ficsclient.com
+bug-reports: https://github.com/tgass/macbeth/issues
+category: game
+version: 0.0.12
+cabal-version: >= 1.8
+build-type: Simple
+license: GPL
+license-file: LICENSE
+data-dir: resources
+extra-source-files: test/*.hs
+source-repository head
+ type: git
+ location: https://github.com/tgass/macbeth
+
+library
+ build-depends: base >=4.2 && <5, wxcore, wx, network, conduit, conduit-extra, text, transformers, resourcet,
+ bytestring, split, attoparsec, filepath, containers, split, mtl, stm, sodium, directory, filepath,
+ time, MissingH, old-locale, safe, FindBin, yaml, either-unwrap
+ hs-source-dirs: src
+ exposed-modules: Paths,
+ Macbeth.Fics.FicsConnection
+ Macbeth.Fics.FicsMessage,
+ Macbeth.Fics.Configuration,
+ Macbeth.Fics.Api.Api,
+ Macbeth.Fics.Api.Challenge,
+ Macbeth.Fics.Api.Game,
+ Macbeth.Fics.Api.Move,
+ Macbeth.Fics.Api.Rating,
+ Macbeth.Fics.Api.PendingOffer,
+ Macbeth.Fics.Api.Seek,
+ Macbeth.Fics.Api.Player,
+ Macbeth.Fics.Parsers.Api,
+ Macbeth.Fics.Parsers.FicsMessageParser,
+ Macbeth.Fics.Parsers.GamesParser,
+ Macbeth.Fics.Parsers.MoveParser,
+ Macbeth.Fics.Parsers.PositionParser,
+ Macbeth.Fics.Parsers.Players,
+ Macbeth.Fics.Parsers.RatingParser,
+ Macbeth.Fics.Parsers.SeekMsgParsers,
+ Macbeth.Fics.Utils.Bitmask,
+ Macbeth.Utils.BoardUtils,
+ Macbeth.Utils.PGN,
+ Macbeth.Utils.FEN,
+ Macbeth.Utils.Utils,
+ Macbeth.Wx.BoardState,
+ Macbeth.Wx.Board,
+ Macbeth.Wx.Challenge,
+ Macbeth.Wx.StatusPanel,
+ Macbeth.Wx.Configuration,
+ Macbeth.Wx.Finger,
+ Macbeth.Wx.GamesList,
+ Macbeth.Wx.GameMoves,
+ Macbeth.Wx.GameType,
+ Macbeth.Wx.Login,
+ Macbeth.Wx.Match,
+ Macbeth.Wx.Game,
+ Macbeth.Wx.Pending,
+ Macbeth.Wx.PartnerOffer,
+ Macbeth.Wx.PieceSet,
+ Macbeth.Wx.PlayersList,
+ Macbeth.Wx.Seek,
+ Macbeth.Wx.SoughtList,
+ Macbeth.Wx.ToolBox,
+ Macbeth.Wx.Utils
+ other-modules: Paths_Macbeth
+ ghc-options: -W
+
+executable Macbeth
+ main-is: src/Macbeth.hs
+ build-depends: base >= 4.2, wx, wxcore, macbeth-lib, stm
+ ghc-options: -O3 -threaded -W
+
+test-suite macbeth-lib-test
+ type: exitcode-stdio-1.0
+ ghc-options: -W
+ hs-source-dirs: test
+ main-is: Spec.hs
+ build-depends: macbeth-lib, base, hspec == 2.*, bytestring, attoparsec
diff --git a/src/Macbeth.hs b/src/Macbeth.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import Macbeth.Fics.FicsConnection
+import Macbeth.Wx.ToolBox
+
+import Graphics.UI.WX
+
+main :: IO ()
+main = do
+ (h, chan) <- ficsConnection
+ start $ wxToolBox h chan
diff --git a/src/Macbeth/Fics/Api/Api.hs b/src/Macbeth/Fics/Api/Api.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Api.hs
@@ -0,0 +1,51 @@
+module Macbeth.Fics.Api.Api (
+ PColor (..),
+ Piece (..),
+ PType (..),
+ Square (..),
+ Row (..),
+ Column (..),
+ Position,
+ MoveDetailed (..),
+ Username,
+ pColor,
+ invert
+) where
+
+import Data.Char
+
+data Column = A | B | C | D | E | F | G | H deriving (Show, Enum, Bounded, Eq)
+
+data Row = One | Two | Three | Four | Five | Six | Seven | Eight deriving (Show, Eq, Enum, Bounded)
+
+data Square = Square Column Row deriving (Eq)
+
+instance Show Square where
+ show (Square s y) = fmap toLower (show s) ++ show (fromEnum y + 1)
+
+data PType = Pawn | Rook | Knight | Bishop | Queen | King deriving (Ord, Eq)
+
+instance Show PType where
+ show Pawn = "P"
+ show Rook = "R"
+ show Knight = "N"
+ show Bishop = "B"
+ show Queen = "Q"
+ show King = "K"
+
+data PColor = Black | White deriving (Show, Eq, Read)
+
+data Piece = Piece PType PColor deriving (Show, Eq)
+
+type Position = [(Square, Piece)]
+
+data MoveDetailed = Simple Square Square | Drop Square | CastleLong | CastleShort deriving (Show, Eq)
+
+type Username = String
+
+pColor :: Piece -> PColor
+pColor (Piece _ color) = color
+
+invert :: PColor -> PColor
+invert White = Black
+invert Black = White
diff --git a/src/Macbeth/Fics/Api/Challenge.hs b/src/Macbeth/Fics/Api/Challenge.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Challenge.hs
@@ -0,0 +1,15 @@
+module Macbeth.Fics.Api.Challenge (
+ Challenge (..),
+ displayChallenge
+) where
+
+import Macbeth.Fics.Api.Rating
+
+data Challenge = Challenge { nameW :: String
+ , ratingW :: Rating
+ , nameB :: String
+ , ratingB :: Rating
+ , params :: String } deriving (Show, Eq)
+
+displayChallenge :: Challenge -> String
+displayChallenge c = nameW c ++ " (" ++ show (ratingW c) ++ ") vs. " ++ nameB c ++ " (" ++ show (ratingB c) ++ ") " ++ params c
diff --git a/src/Macbeth/Fics/Api/Game.hs b/src/Macbeth/Fics/Api/Game.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Game.hs
@@ -0,0 +1,43 @@
+module Macbeth.Fics.Api.Game (
+ Game (..),
+ GameType (..),
+ GameSettings (..),
+ GameResult (..),
+ GameInfo (..)
+) where
+
+import Macbeth.Fics.Api.Rating
+
+data GameType = Blitz | Lightning | Untimed | ExaminedGame | Standard | Wild | Atomic |
+ Crazyhouse | Bughouse | Losers | Suicide | NonStandardGame deriving (Show, Eq)
+
+data Game = Game {
+ id :: Int
+ , isExample :: Bool
+ , isSetup :: Bool
+ , ratingW :: Rating
+ , nameW :: String
+ , ratingB :: Rating
+ , nameB :: String
+ , settings :: GameSettings } deriving (Show, Eq)
+
+data GameSettings = GameSettings {
+ isPrivate :: Bool
+ , gameType :: GameType
+ , isRated :: Bool} deriving (Show, Eq)
+
+data GameInfo = GameInfo {
+ _nameW :: String
+ , _ratingW :: Rating
+ , _nameB :: String
+ , _ratingB :: Rating
+} deriving (Show, Eq)
+
+data GameResult = WhiteWins | BlackWins | Draw | Aborted deriving (Eq)
+
+instance Show GameResult where
+ show WhiteWins = "1-0"
+ show BlackWins = "0-1"
+ show Draw = "1/2-1/2"
+ show Aborted = ""
+
diff --git a/src/Macbeth/Fics/Api/Move.hs b/src/Macbeth/Fics/Api/Move.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Move.hs
@@ -0,0 +1,156 @@
+module Macbeth.Fics.Api.Move (
+ Move(..),
+ Relation(..),
+ Castling(..),
+ MoveModifier(..),
+ remainingTime,
+ decreaseRemainingTime,
+ nameUser,
+ colorUser,
+ namePlayer,
+ isGameUser,
+ isNextMoveUser,
+ isNewGameUser,
+ isOponentMove,
+ wasOponentMove,
+ playerColor,
+ nameOponent,
+ isCheckmate,
+ toGameResultTuple,
+ dummyMove
+) where
+
+import Macbeth.Fics.Api.Api
+import qualified Macbeth.Fics.Api.Game as Game
+
+import Data.Maybe
+
+data Move = Move {
+ positionRaw :: String
+ , position :: [(Square, Piece)]
+ , turn :: PColor
+ , doublePawnPush :: Maybe Column
+ , castlingAv :: [Castling]
+ , ply :: Int
+ , gameId :: Int
+ , nameW :: String
+ , nameB :: String
+ , relation :: Relation
+ , initialTime :: Int
+ , incPerMove :: Int
+ , whiteRelStrength :: Int
+ , blackRelStrength :: Int
+ , remainingTimeW :: Int
+ , remainingTimeB :: Int
+ , moveNumber :: Int
+ , moveVerbose :: Maybe MoveDetailed
+ , timeTaken :: String
+ , movePretty :: Maybe String
+ } deriving (Eq, Show)
+
+data Relation = IsolatedPosition | ObservingExaminedGame | Examiner | MyMove | OponentsMove | Observing deriving (Show, Eq)
+
+data Castling = WhiteLong | WhiteShort | BlackLong | BlackShort deriving (Show, Eq)
+
+data MoveModifier = None | Illegal | Takeback (Maybe Username) deriving (Eq)
+
+instance Show MoveModifier where
+ show Illegal = "Illegal move."
+ show (Takeback (Just username)) = username ++ " accepts the takeback request."
+ show (Takeback Nothing) = ""
+ show None = ""
+
+remainingTime :: PColor -> Move -> Int
+remainingTime Black = remainingTimeB
+remainingTime White = remainingTimeW
+
+
+decreaseRemainingTime :: PColor -> Move -> Move
+decreaseRemainingTime Black move = move {remainingTimeB = max 0 $ remainingTimeB move - 1}
+decreaseRemainingTime White move = move {remainingTimeW = max 0 $ remainingTimeW move - 1}
+
+
+nameUser :: Move -> String
+nameUser m = namePlayer (colorUser m) m
+
+
+colorUser :: Move -> PColor
+colorUser m = if relation m == MyMove then turn m else invert $ turn m
+
+
+isGameUser :: Move -> Bool
+isGameUser m = relation m `elem` [MyMove, OponentsMove]
+
+
+isNextMoveUser :: Move -> Bool
+isNextMoveUser m = relation m == MyMove
+
+
+isNewGameUser :: Move -> Bool
+isNewGameUser m = isGameUser m && isNothing (movePretty m)
+
+
+isOponentMove :: Move -> Bool
+isOponentMove m = relation m == OponentsMove
+
+
+wasOponentMove :: Move -> Bool
+wasOponentMove m = colorUser m == turn m
+
+
+namePlayer :: PColor -> Move -> String
+namePlayer White = nameW
+namePlayer Black = nameB
+
+
+nameOponent :: Move -> String
+nameOponent m = namePlayer (invert $ colorUser m) m
+
+
+playerColor :: String -> Move -> PColor
+playerColor name move
+ | nameW move == name = White
+ | otherwise = Black
+
+
+isCheckmate :: Move -> Bool
+isCheckmate = maybe False ((== '#') . last) . movePretty
+
+
+toGameResultTuple :: Move -> (Int, String, Game.GameResult)
+toGameResultTuple move = (gameId move, namePlayer colorTurn move ++ " checkmated", turnToGameResult colorTurn)
+ where
+ colorTurn = turn move
+ turnToGameResult Black = Game.WhiteWins
+ turnToGameResult White = Game.BlackWins
+
+
+dummyMove :: Move
+dummyMove = Move {
+ positionRaw = "",
+ position = [ (Square A One, Piece Rook White)
+ , (Square A Two, Piece Pawn White)
+ , (Square B Two, Piece Pawn White)
+ , (Square C Two, Piece Pawn White)
+ , (Square E Eight, Piece King Black)
+ , (Square D Eight, Piece Queen Black)
+ ],
+ turn = Black,
+ doublePawnPush = Nothing,
+ castlingAv = [],
+ ply = 0,
+ gameId = 1,
+ nameW = "foobar",
+ nameB = "barbaz",
+ relation = MyMove,
+ moveNumber = 0,
+ moveVerbose = Nothing,
+ timeTaken = "0",
+ remainingTimeW = 0,
+ remainingTimeB = 0,
+ movePretty = Just "f2"
+ , initialTime = 300
+ , incPerMove = 0
+ , whiteRelStrength = 120
+ , blackRelStrength = 120
+ }
diff --git a/src/Macbeth/Fics/Api/PendingOffer.hs b/src/Macbeth/Fics/Api/PendingOffer.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/PendingOffer.hs
@@ -0,0 +1,23 @@
+module Macbeth.Fics.Api.PendingOffer (
+ PendingOffer(..),
+ Origin (..),
+ isFrom,
+ isTo
+) where
+
+import Macbeth.Fics.Api.Player
+
+data Origin = From | To deriving (Show, Eq)
+
+data PendingOffer = PendingOffer {
+ origin :: Origin
+ , offerId :: Int
+ , playerName :: UserHandle
+ , offerType :: String
+ , params :: String } deriving (Show, Eq)
+
+isFrom :: PendingOffer -> Bool
+isFrom = (== From) . origin
+
+isTo :: PendingOffer -> Bool
+isTo = (== To) . origin
diff --git a/src/Macbeth/Fics/Api/Player.hs b/src/Macbeth/Fics/Api/Player.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Player.hs
@@ -0,0 +1,45 @@
+module Macbeth.Fics.Api.Player (
+ Player (..),
+ Status (..),
+ UserHandle (..),
+ HandleType (..)
+) where
+
+import Macbeth.Fics.Api.Rating hiding (None)
+
+data Player = Player {
+ rating :: Rating
+ , status :: Status
+ , handle :: UserHandle } deriving (Eq, Show)
+
+data Status = InvolvedInAGame
+ | RunningASimulMatch
+ | NotOpenForMatch
+ | ExaminingAGame
+ | InactiveOrBusy
+ | NotBusy
+ | InvolvedInATournament deriving (Eq, Show)
+
+
+data UserHandle = UserHandle {
+ name :: String
+ , handleType :: [HandleType] } deriving (Eq, Show)
+
+
+data HandleType = Admin
+ | Blindfold
+ | Computer
+ | NOT_DOCUMENTED -- ^ (D) is not documented
+ | Team
+ | Unregistered
+ | ChessAdvisor
+ | ServiceRepresentative
+ | TournamentDirectorOrBot
+ | MamerManager
+ | GrandMaster
+ | InternationalMaster
+ | FideMaster
+ | WomenGrandMaster
+ | WomenInternationalMaster
+ | WomenFideMaster deriving (Eq, Show)
+
diff --git a/src/Macbeth/Fics/Api/Rating.hs b/src/Macbeth/Fics/Api/Rating.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Rating.hs
@@ -0,0 +1,19 @@
+module Macbeth.Fics.Api.Rating (
+ Rating (..),
+ ProvShow (..)
+) where
+
+data Rating = Rating {r :: Int, provShow :: ProvShow} | Unrated | Guest deriving (Eq)
+
+data ProvShow = None | Estimated | Provisional deriving (Eq)
+
+instance Show ProvShow where
+ show None = ""
+ show Estimated = "E"
+ show Provisional = "P"
+
+instance Show Rating where
+ show (Rating r' ps) = show r' ++ show ps
+ show Guest = "Guest"
+ show Unrated = "Unrated"
+
diff --git a/src/Macbeth/Fics/Api/Seek.hs b/src/Macbeth/Fics/Api/Seek.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Api/Seek.hs
@@ -0,0 +1,38 @@
+module Macbeth.Fics.Api.Seek (
+ Seek (..),
+ StartMode,
+ Title (..)
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.Api.Rating
+import Macbeth.Fics.Utils.Bitmask
+
+data Seek = Seek {
+ id :: Int
+ , name :: String
+ , titles :: [Title] -- It is unlikely the titles will ever be mixed though as they should be exclusive. However the server does allow this.
+ , rating :: Rating
+ , timeStart :: Int
+ , timeIncPerMove :: Int
+ , isRated :: Bool
+ , gameType :: GameType
+ , color :: Maybe PColor
+ , ratingRange :: (Int, Int)
+-- , startMode :: StartMode
+-- , checkFormula :: Bool
+} deriving (Eq, Show)
+
+data StartMode = Auto | Manual deriving (Show)
+
+data Title = Unregistered
+ | Computer
+ | GrandMaster
+ | InternationalMaster
+ | FideMaster
+ | WomenGrandMaster
+ | WomenInternationalMaster
+ | WomenFideMaster deriving (Bounded, Enum, Eq, Show)
+
+instance ToBitMask Title
diff --git a/src/Macbeth/Fics/Configuration.hs b/src/Macbeth/Fics/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Configuration.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Macbeth.Fics.Configuration (
+ Config(..),
+ Logging(..),
+ loadConfig,
+ loadDefaultConfig,
+ saveConfig
+) where
+
+import Paths
+
+import Control.Monad.Except
+import Data.Either.Unwrap
+import System.Directory
+import System.FilePath
+import GHC.Generics
+import qualified Data.Yaml as Y
+
+data Config = Config {
+ directory :: Maybe FilePath,
+ logging :: Logging
+} deriving (Show, Generic)
+
+data Logging = Logging {
+ stdOut :: Bool,
+ file :: Bool
+} deriving (Show, Generic)
+
+instance Y.FromJSON Config
+instance Y.ToJSON Config
+
+instance Y.FromJSON Logging
+instance Y.ToJSON Logging
+
+
+loadConfig :: IO Config
+loadConfig = fmap fromRight $ runExceptT $ fromDisk `catchError` (\_ -> return defaultConfig)
+
+loadDefaultConfig :: IO Config
+loadDefaultConfig = do
+ dir <- getDefaultDirectory Nothing
+ return $ defaultConfig {directory = Just dir}
+
+
+-- | If no directory is set, set default directory ~/Macbeth
+fromDisk :: ExceptT Y.ParseException IO Config
+fromDisk = do
+ config <- ExceptT $ getDataFileName "macbeth.yaml" >>= Y.decodeFileEither
+ dir <- liftIO $ getDefaultDirectory (directory config)
+ return $ config {directory = Just dir}
+
+-- | Create default directory if it doesn't exist
+getDefaultDirectory :: Maybe FilePath -> IO FilePath
+getDefaultDirectory Nothing = do
+ dir <- ( "Macbeth") `fmap` getUserDocumentsDirectory
+ createDirectoryIfMissing False dir
+ return dir
+getDefaultDirectory (Just path) = return path
+
+saveConfig :: Config -> IO ()
+saveConfig config = getDataFileName "macbeth.yaml" >>= flip Y.encodeFile config
+
+defaultConfig = Config {
+ directory = Nothing,
+ logging = Logging False False
+}
+
diff --git a/src/Macbeth/Fics/FicsConnection.hs b/src/Macbeth/Fics/FicsConnection.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/FicsConnection.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Macbeth.Fics.FicsConnection (
+ ficsConnection
+) where
+
+import Macbeth.Fics.Configuration
+import Macbeth.Fics.FicsMessage hiding (gameId)
+import Macbeth.Fics.Api.Move hiding (Observing)
+import Macbeth.Fics.Parsers.FicsMessageParser
+
+import Control.Concurrent.Chan
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans.Resource
+import Data.Char
+import Data.Conduit
+import Data.Conduit.Binary
+import Data.Conduit.List hiding (filter)
+import Data.Maybe
+import Data.Time
+import Network
+import System.FilePath
+import System.IO
+
+import qualified Data.ByteString.Char8 as BS
+
+
+data HelperState = HelperState { config :: Config
+ , takebackAccptedBy :: Maybe String -- ^ oponent accepted takeback request
+ , observingGameId :: Maybe Int
+ , newGameId :: Maybe Int }
+
+
+ficsConnection :: IO (Handle, Chan FicsMessage)
+ficsConnection = runResourceT $ do
+ (_, hsock) <- allocate (connectTo "freechess.org" $ PortNumber 5000) hClose
+ liftIO $ hSetBuffering hsock LineBuffering
+ config <- liftIO loadConfig
+ chan <- liftIO newChan
+ resourceForkIO $ liftIO $ chain hsock config chan
+ return (hsock, chan)
+
+
+chain :: Handle -> Config-> Chan FicsMessage -> IO ()
+chain h config chan = flip evalStateT emptyState $ transPipe lift
+ (sourceHandle h) $$
+ linesC =$
+ blockC BS.empty =$
+ unblockC =$
+ fileLoggerC =$
+ parseC =$
+ stateC =$
+ copyC chan =$
+ loggingC =$
+ sink chan
+ where emptyState = HelperState config Nothing Nothing Nothing
+
+
+sink :: Chan FicsMessage -> Sink FicsMessage (StateT HelperState IO) ()
+sink chan = awaitForever $ liftIO . writeChan chan
+
+
+loggingC :: Conduit FicsMessage (StateT HelperState IO) FicsMessage
+loggingC = awaitForever $ \cmd -> do
+ logToStdOut <- (stdOut . logging . config) `fmap` get
+ when logToStdOut $ liftIO (printCmdMsg cmd)
+ yield cmd
+
+
+copyC :: Chan FicsMessage -> Conduit FicsMessage (StateT HelperState IO) FicsMessage
+copyC chan = awaitForever $ \case
+ m@(MatchAccepted move) -> do
+ chan' <- liftIO $ dupChan chan
+ sourceList [m, WxMatchAccepted move chan']
+ m@(Observe move) -> do
+ chan' <- liftIO $ dupChan chan
+ sourceList [m, WxObserve move chan']
+ cmd -> yield cmd
+
+
+stateC :: Conduit FicsMessage (StateT HelperState IO) FicsMessage
+stateC = awaitForever $ \cmd -> do
+ state <- get
+ case cmd of
+ GameCreation id -> do
+ put $ state {newGameId = Just id}
+ sourceNull
+
+ Observing id -> do
+ put $ state {observingGameId = Just id}
+ sourceNull
+
+ TakebackAccepted username -> do
+ put $ state {takebackAccptedBy = Just username}
+ sourceNull
+
+ m@(GameMove _ move)
+ | isCheckmate move && isOponentMove move -> sourceList $ cmd : [toGameResult move]
+ | isNewGameUser move && fromMaybe False ((== gameId move) <$> newGameId state) -> do
+ put $ state {newGameId = Nothing }
+ sourceList [MatchAccepted move]
+ | fromMaybe False ((== gameId move) <$> observingGameId state) -> do
+ put $ state {observingGameId = Nothing }
+ sourceList [Observe move]
+ | isJust $ takebackAccptedBy state -> do
+ put $ state {takebackAccptedBy = Nothing}
+ sourceList [m{context = Takeback $ takebackAccptedBy state}]
+ | otherwise -> sourceList [m]
+
+ _ -> yield cmd
+
+
+parseC :: Conduit BS.ByteString (StateT HelperState IO) FicsMessage
+parseC = awaitForever $ \str -> case parseFicsMessage str of
+ Left _ -> yield $ TextMessage $ BS.unpack str
+ Right cmd -> yield cmd
+
+
+unblockC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString
+unblockC = awaitForever $ \block -> case ord $ BS.head block of
+ 21 -> if readId block `elem` [
+ 1 -- game move
+ , 10 -- Abort
+ , 11 -- Accept (Draw, Abort)
+ , 33 -- Decline (ie match offer)
+ , 34 -- Draw (Mutual)
+ , 80 -- Observing
+ , 103 -- Resign
+ , 155 -- Seek (Users' seek matches a seek already posted)
+ , 158 -- Play (User selects a seek)
+ , 56 -- BLK_ISET, seekinfo set.
+ ]
+ then sourceList (lines $ crop block) else yield block
+ _ -> yield block
+ where
+ crop :: BS.ByteString -> BS.ByteString
+ crop bs = let lastIdx = maybe 0 (+1) (BS.elemIndexEnd (chr 22) bs) in
+ BS.drop lastIdx $ BS.init bs
+
+ lines :: BS.ByteString -> [BS.ByteString]
+ lines bs = fmap (`BS.snoc` '\n') $ init $ filter (not . BS.null) $ BS.split '\n' bs
+
+ readId :: BS.ByteString -> Int
+ readId = read . BS.unpack . BS.takeWhile (/= chr 22) . BS.tail . BS.dropWhile (/= chr 22)
+
+
+blockC :: BS.ByteString -> Conduit BS.ByteString (StateT HelperState IO) BS.ByteString
+blockC block = awaitForever $ \line -> case ord $ BS.head line of
+ 21 -> blockC line
+ 23 -> yield (block `BS.append` line) >> blockC BS.empty -- ^ don't ever delete this again!
+ _ | BS.null block -> unless (line `elem` ignore) $ yield line
+ | otherwise -> blockC $ block `BS.append` line
+ where ignore = [BS.pack "\n", BS.pack "\a\n"]
+
+
+-- remember!! "fics% \NAK4\SYN87\SYNThere are no offers pending to other players."
+linesC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString
+linesC = awaitForever $ sourceList . filter (not . BS.null) . fmap dropPrompt . BS.split '\r'
+
+
+dropPrompt :: BS.ByteString -> BS.ByteString
+dropPrompt line
+ | BS.take promptSz line == prompt = BS.drop promptSz line
+ | otherwise = line
+ where prompt = BS.pack "fics% "
+ promptSz = BS.length prompt
+
+
+fileLoggerC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString
+fileLoggerC = awaitForever $ \chunk -> do
+ config <- config `fmap` get
+ when (file (logging config) && isJust (directory config)) $
+ liftIO $ logFile (fromJust $ directory config) chunk
+ yield chunk
+
+
+toGameResult :: Move -> FicsMessage
+toGameResult move = GameResult id reason result
+ where (id, reason, result) = toGameResultTuple move
+
+
+printCmdMsg :: FicsMessage -> IO ()
+printCmdMsg NewSeek {} = return ()
+printCmdMsg RemoveSeeks {} = return ()
+printCmdMsg cmd = print cmd
+
+
+logFile :: FilePath -> BS.ByteString -> IO ()
+logFile path chunk = do
+ date <- fmap (formatTime Data.Time.defaultTimeLocale "%Y-%m-%d_") getZonedTime
+ dateTime <- fmap (formatTime Data.Time.defaultTimeLocale "%Y-%m-%d %H-%M-%S: ") getZonedTime
+ appendFile (path date ++ "macbeth.log") $
+ (foldr (.) (showString $ "\n" ++ dateTime) $ fmap showLitChar (BS.unpack chunk)) ""
+
diff --git a/src/Macbeth/Fics/FicsMessage.hs b/src/Macbeth/Fics/FicsMessage.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/FicsMessage.hs
@@ -0,0 +1,99 @@
+module Macbeth.Fics.FicsMessage (
+ FicsMessage (..)
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Player
+import Macbeth.Fics.Api.Challenge
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.Api.Move
+import Macbeth.Fics.Api.PendingOffer
+import Macbeth.Fics.Api.Seek
+
+import Control.Concurrent.Chan
+
+data FicsMessage =
+ -- | 1. Confirmation of a user move
+ -- 2. Reseted position after illegal user move
+ -- 3. Move by oponent
+ GameMove { context :: MoveModifier, move :: Move }
+
+ -- | Pieces holdings in Bughouse / Crazyhouse games
+ | PieceHolding { gameId :: Int, phWhite :: [PType], phBlack :: [PType] }
+
+ -- | Answer to 'observe' command (BLK_OBSERVE 80)
+ | Observe Move
+
+ -- | If id in 'observe id' does not exist
+ | NoSuchGame
+ | UserNotLoggedIn Username
+
+ -- | Match offered by another player
+ | MatchRequested Challenge
+
+ -- | Starts a new game. Let it be after 'seek' or 'match' or resuming a pending game.
+ -- Indifferent of whether the user or his oponent started the interaction.
+ | MatchAccepted Move
+ | MatchDeclined Username
+ | MatchUserNotLoggedIn Username
+
+ -- | Not concering if the user or his oponent is checkmated/out of time/.. GameResult informs
+ -- that the game is over.
+ | GameResult { gameId :: Int, reason :: String, result :: GameResult }
+
+ | Pending PendingOffer
+ | PendingRemoved Int
+
+ -- | The oponents wants to draw.
+ | DrawRequest
+ | DrawRequestDeclined Username
+
+ -- | The oponent wants to abort.
+ | AbortRequest Username
+ | AbortRequestDeclined Username
+
+ -- | The oponent wants to takeback one or more half-moves
+ | TakebackRequest Username Int
+
+ -- | Promotion piece
+ | PromotionPiece PType
+
+ | NewSeek Seek
+ | RemoveSeeks [Int]
+ | ClearSeek
+ | SeekNotAvailable
+
+ | PartnerNotOpen UserHandle
+ | PartnerOffer UserHandle
+ | PartnerAccepted UserHandle
+ | PartnerDeclined UserHandle
+
+ -- | Answer to 'games' command (BLK_GAMES 43)
+ | Games [Game]
+ | Players [Player]
+ | Finger UserHandle String
+ | History UserHandle String
+ | Ping {lagMin :: Int, lagAvg :: Int, lagMax :: Int}
+
+ | Login
+ | LoginTimeout
+ | Password
+ | GuestLogin Username
+ | LoggedIn UserHandle
+ | InvalidPassword
+ | TextMessage String
+
+ {- Unused -}
+ | UnkownUsername Username
+
+ {- Internal -}
+ | GameCreation Int
+ | Observing Int
+ | TakebackAccepted Username
+ | WxClose
+ | WxMatchAccepted Move (Chan FicsMessage)
+ | WxObserve Move (Chan FicsMessage) deriving (Show, Eq)
+
+instance Show (Chan a) where
+ show _ = "Chan"
+
diff --git a/src/Macbeth/Fics/Parsers/Api.hs b/src/Macbeth/Fics/Parsers/Api.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/Api.hs
@@ -0,0 +1,20 @@
+module Macbeth.Fics.Parsers.Api (
+ commandHead
+) where
+
+import Data.Attoparsec.ByteString.Char8
+import Data.Char
+import qualified Data.ByteString.Char8 as BS
+
+data CommandHead = CommandHead Int deriving (Show)
+
+commandHead :: Int -> Parser CommandHead
+commandHead code = do
+ char $ chr 21
+ id <- decimal
+ char $ chr 22
+ string $ BS.pack $ show code
+ char $ chr 22
+ return $ CommandHead id
+
+
diff --git a/src/Macbeth/Fics/Parsers/FicsMessageParser.hs b/src/Macbeth/Fics/Parsers/FicsMessageParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/FicsMessageParser.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.FicsMessageParser (
+ parseFicsMessage
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Challenge
+import Macbeth.Fics.FicsMessage hiding (move)
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.Api.Move hiding (Observing)
+import Macbeth.Fics.Api.PendingOffer
+import Macbeth.Fics.Parsers.Api
+import Macbeth.Fics.Parsers.GamesParser
+import Macbeth.Fics.Parsers.MoveParser
+import Macbeth.Fics.Parsers.RatingParser
+import qualified Macbeth.Fics.Parsers.Players as P
+import qualified Macbeth.Fics.Parsers.SeekMsgParsers as SP
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString.Char8 as BS
+
+
+parseFicsMessage :: BS.ByteString -> Either String FicsMessage
+parseFicsMessage = parseOnly parser where
+ parser = choice [ SP.clearSeek
+ , SP.newSeek
+ , SP.removeSeeks
+ , SP.seekNotAvailable
+
+ , gameMove
+ , gameCreation
+ , pieceHolding
+
+ , challenge
+ , matchDeclined
+ , matchUserNotLoggedIn
+
+ , games
+ , observing
+ , noSuchGame
+ , userNotLoggedIn
+
+ , abortRequest
+ , abortRequestDeclined
+
+ , takebackRequest
+ , takebackAccepted
+ , acceptTakeback
+
+ , drawRequest
+ , drawRequestDeclined
+
+ , gameResult'
+
+ , promotionPiece
+
+ , P.finger
+ , P.history
+ , P.players
+ , P.partnerNotOpen
+ , P.partnerOffer
+ , P.partnerAccepted
+ , P.partnerDeclined
+
+ , pending
+ , pendingTo
+ , pendingRemoved
+ , pendingWithdraw
+
+ , login
+ , loginTimeout
+ , password
+ , guestLogin
+ , unknownUsername
+ , loggedIn
+ , invalidPassword
+ , ping
+ ]
+
+gameMove :: Parser FicsMessage
+gameMove = GameMove <$> pure None <*> move
+
+gameCreation :: Parser FicsMessage
+gameCreation = GameCreation <$> ("{Game " *> decimal <* takeTill (== ')') <* ") Creating ")
+
+observing :: Parser FicsMessage
+observing = Observing <$> ("You are now observing game " *> decimal)
+
+noSuchGame :: Parser FicsMessage
+noSuchGame = commandHead 80 *> "There is no such game." *> pure NoSuchGame
+
+userNotLoggedIn :: Parser FicsMessage
+userNotLoggedIn = UserNotLoggedIn <$> (commandHead 80 *> many1 letter_ascii <* " is not logged in.\n\ETB")
+
+games :: Parser FicsMessage
+games = Games <$> (commandHead 43 *> parseGamesList)
+
+challenge :: Parser FicsMessage
+challenge = MatchRequested <$> (Challenge
+ <$> ("Challenge: " *> manyTill anyChar space)
+ <*> ("(" *> skipSpace *> rating)
+ <*> (") " *> manyTill anyChar space)
+ <*> ("(" *> skipSpace *> rating)
+ <*> (") " *> manyTill anyChar ".")) --unrated blitz 2 12."
+
+matchDeclined :: Parser FicsMessage
+matchDeclined = MatchDeclined <$> ("\"" *> manyTill anyChar "\" declines the match offer.")
+
+matchUserNotLoggedIn :: Parser FicsMessage
+matchUserNotLoggedIn = MatchUserNotLoggedIn <$> (commandHead 73 *> manyTill anyChar " " <* "is not logged in.")
+
+drawRequest :: Parser FicsMessage
+drawRequest = manyTill anyChar space *> "offers you a draw." *> pure DrawRequest
+
+drawRequestDeclined :: Parser FicsMessage
+drawRequestDeclined = DrawRequestDeclined <$> manyTill anyChar space <* "declines the draw request."
+
+abortRequest :: Parser FicsMessage
+abortRequest = AbortRequest <$> (manyTill anyChar " " <* "would like to abort the game;")
+
+abortRequestDeclined :: Parser FicsMessage
+abortRequestDeclined = AbortRequestDeclined <$> manyTill anyChar space <* "declines the abort request."
+
+takebackRequest :: Parser FicsMessage
+takebackRequest = TakebackRequest
+ <$> manyTill anyChar " " <* "would like to take back "
+ <*> decimal <* " half move(s)."
+
+takebackAccepted :: Parser FicsMessage
+takebackAccepted = TakebackAccepted <$> manyTill anyChar " " <* "accepts the takeback request."
+
+acceptTakeback :: Parser FicsMessage
+acceptTakeback = GameMove <$>
+ pure (Takeback Nothing) <*> -- ^ User accepted takeback himself
+ (commandHead 11 *> "You accept the takeback request from" *> takeTill (== '<') *> move)
+
+gameResult' :: Parser FicsMessage
+gameResult' = GameResult
+ <$> (takeTill (== '{') *> "{Game " *> decimal)
+ <*> (takeTill (== ')') *> ") " *> manyTill anyChar "} ")
+ <*> ("1-0" *> pure WhiteWins <|> "0-1" *> pure BlackWins <|> "1/2-1/2" *> pure Draw <|> "*" *> pure Aborted)
+
+promotionPiece :: Parser FicsMessage
+promotionPiece = PromotionPiece <$> (commandHead 92 *> "Promotion piece set to " *>
+ ("QUEEN" *> pure Queen <|> "BISHOP" *> pure Bishop <|> "KNIGHT" *> pure Knight <|> "ROOK" *> pure Rook <|> "KING" *> pure King))
+
+pending :: Parser FicsMessage
+pending = Pending <$> (PendingOffer
+ <$> (("" *> pure From) <|> ("" *> pure To))
+ <*> (" " *> decimal)
+ <*> (" w=" *> P.userHandle)
+ <*> (" t=" *> manyTill anyChar " ")
+ <*> ("p=" *> manyTill anyChar "\n"))
+
+pendingTo :: Parser FicsMessage
+pendingTo = commandHead 73 *> takeTill (=='<') *> pending
+
+pendingRemoved :: Parser FicsMessage
+pendingRemoved = PendingRemoved <$> (" " *> decimal)
+
+pendingWithdraw :: Parser FicsMessage
+pendingWithdraw = commandHead 147 *> takeTill (=='<') *> pendingRemoved
+
+login :: Parser FicsMessage
+login = "login: " *> pure Login
+
+loginTimeout :: Parser FicsMessage
+loginTimeout = "**** LOGIN TIMEOUT ****" *> pure LoginTimeout
+
+password :: Parser FicsMessage
+password = "password: " *> pure Password
+
+guestLogin :: Parser FicsMessage
+guestLogin = GuestLogin <$> ("Press return to enter the server as \"" *> manyTill anyChar "\":")
+
+unknownUsername :: Parser FicsMessage
+unknownUsername = UnkownUsername <$> ("\"" *> manyTill anyChar "\" is not a registered name.")
+
+loggedIn :: Parser FicsMessage
+loggedIn = LoggedIn <$> ("**** Starting FICS session as " *> P.userHandle <* " ****")
+
+invalidPassword :: Parser FicsMessage
+invalidPassword = "**** Invalid password! ****" *> pure InvalidPassword
+
+ping :: Parser FicsMessage
+ping = Ping
+ <$> (":min/avg/max/mdev = " *> round `fmap` double)
+ <*> ("/" *> round `fmap` double)
+ <*> ("/" *> round `fmap` double)
diff --git a/src/Macbeth/Fics/Parsers/GamesParser.hs b/src/Macbeth/Fics/Parsers/GamesParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/GamesParser.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.GamesParser (
+ parseGamesList
+) where
+
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.Parsers.RatingParser
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+
+
+parseGamesList :: Parser [Game]
+parseGamesList = many' gameP
+
+gameP :: Parser Game
+gameP = Game
+ <$> (takeTill (== '\n') *> "\n" *> many space *> decimal)
+ <*> (many1 space *> option False ("(Exam." *> pure True))
+ <*> (option False ("(Setup" *> pure True))
+ <*> (many space *> rating)
+ <*> (many1 space *> manyTill anyChar space)
+ <*> (many space *> rating)
+ <*> (many1 space *> manyTill anyChar (space <|> char ')'))
+ <*> (takeTill (== '[') *> "[" *> settings')
+
+
+settings' :: Parser GameSettings
+settings' = GameSettings
+ <$> (space *> pure False <|> char 'p' *> pure True)
+ <*> gameType'
+ <*> (char 'u' *> pure False <|> char 'r' *> pure True)
+
+
+gameType' :: Parser GameType
+gameType' =
+ "b" *> pure Blitz <|>
+ "l" *> pure Lightning <|>
+ "u" *> pure Untimed <|>
+ "e" *> pure ExaminedGame <|>
+ "s" *> pure Standard <|>
+ "w" *> pure Wild <|>
+ "x" *> pure Atomic <|>
+ "z" *> pure Crazyhouse <|>
+ "B" *> pure Bughouse <|>
+ "L" *> pure Losers <|>
+ "S" *> pure Suicide <|>
+ "n" *> pure NonStandardGame
+
diff --git a/src/Macbeth/Fics/Parsers/MoveParser.hs b/src/Macbeth/Fics/Parsers/MoveParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/MoveParser.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.MoveParser (
+ move,
+ moveOnly,
+ pieceHolding,
+ pieceHoldingOnly,
+ verboseMove'
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.FicsMessage hiding (move, Observing)
+import Macbeth.Fics.Parsers.PositionParser
+import Macbeth.Fics.Api.Move hiding (relation)
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8 hiding (D)
+import Data.Maybe
+import qualified Data.Attoparsec.ByteString.Char8 as A (take)
+import qualified Data.ByteString.Char8 as BS
+
+--test = BS.pack "<12> --kr-bnr ppp-pppp --nqb--- ---p---- ---P-B-- --NQ---P PPP-PPP- R---KBNR W -1 1 1 0 0 1 345 GuestTVTH GuestPYFX -1 5 0 39 39 282 288 6 o-o-o (0:03) O-O-O 1 1 0"
+--test2 = BS.pack "<12> --kr-bnr ppp-pppp --nqb--- ---p---- ---P-B-- --NQ---P PPP-PPP- R---KBNR W -1 1 1 0 0 1 345 GuestTVTH GuestPYFX -1 5 0 39 39 282 288 6 o-o (0:03) O-O-O 1 1 0"
+--test3 = BS.pack "<12> r--k-b-n ppp-pppP --bpp-b- ---pp--N -------- --P--PB- PPP-pPPP R---R-K- W -1 0 0 0 0 0 408 CarlosFenix mandevil 0 2 0 43 28 48 31 27 B/@@-g6 (0:25) B@g6 0 1 0\n"
+
+move :: Parser Move
+move = "<12>" *> moveOnly
+
+moveOnly :: Parser Move
+moveOnly = do
+ pos <- BS.unpack `fmap` (space *> A.take 71)
+ Move
+ <$> pure pos
+ <*> pure (parsePosition pos)
+ <*> (space *> ("B" *> pure Black <|> "W" *> pure White)) -- turn
+ <*> (space *> ("-1" *> pure Nothing <|> Just `fmap` column)) -- doublePawnPush
+ <*> (catMaybes <$> sequence [ castle WhiteShort, castle WhiteLong, castle BlackShort, castle BlackLong])
+ <*> (space *> decimal) -- the number of moves made since the last irreversible move, halfmove clock
+ <*> (space *> decimal) -- gameId
+ <*> (space *> manyTill anyChar space) -- nameW
+ <*> manyTill anyChar space -- nameB
+ <*> relation
+ <*> (space *> decimal) --initialTime
+ <*> (space *> decimal) --inc per move
+ <*> (space *> decimal) -- whiteRelStrength
+ <*> (space *> decimal) -- blackRelStrength
+ <*> (space *> (decimal <|> ("-" *> (decimal >>= pure . negate)))) -- remTimeWhite
+ <*> (space *> (decimal <|> ("-" *> (decimal >>= pure . negate)))) -- remTimeBlack
+ <*> (space *> decimal) -- moveNumber
+ <*> (space *> verboseMove') -- moveVerbose
+ <*> (space *> manyTill anyChar space) -- timeTaken
+ <*> ("none" *> pure Nothing <|> Just `fmap` manyTill anyChar space) -- movePretty
+
+
+verboseMove' :: Parser (Maybe MoveDetailed)
+verboseMove' = ("none" *> pure Nothing) <|> Just <$> (
+ (Simple <$> (anyChar *> "/" *> square) <*> ("-" *> square <* takeTill (== ' '))) <|>
+ (Drop <$> (anyChar *> "/@@-" *> square <* takeTill (== ' '))) <|>
+ ("o-o-o" *> pure CastleLong) <|>
+ ("o-o" *> pure CastleShort))
+
+
+castle :: Castling -> Parser (Maybe Castling)
+castle c = space *> ("0" *> pure Nothing <|> "1" *> pure (Just c))
+
+
+square :: Parser Square
+square = Square <$> columnAH <*> row
+
+
+columnAH :: Parser Column
+columnAH =
+ "a" *> pure A <|> "b" *> pure B <|> "c" *> pure C <|> "d" *> pure D <|>
+ "e" *> pure E <|> "f" *> pure F <|> "g" *> pure G <|> "h" *> pure H
+
+
+row :: Parser Row
+row =
+ "1" *> pure One <|> "2" *> pure Two <|> "3" *> pure Three <|> "4" *> pure Four <|>
+ "5" *> pure Five <|> "6" *> pure Six <|> "7" *> pure Seven <|> "8" *> pure Eight
+
+
+relation =
+ "-3" *> pure IsolatedPosition <|> "-2" *> pure ObservingExaminedGame <|> "2" *> pure Examiner <|>
+ "-1" *> pure OponentsMove <|> "1" *> pure MyMove <|> "0" *> pure Observing
+
+
+column :: Parser Column
+column =
+ "0" *> pure A <|> "1" *> pure B <|> "2" *> pure C <|> "3" *> pure D <|>
+ "4" *> pure E <|> "5" *> pure F <|> "6" *> pure G <|> "7" *> pure H
+
+
+-- game 455 white [PP] black []
+
+pieceHolding :: Parser FicsMessage
+pieceHolding = "" *> pieceHoldingOnly
+
+pieceHoldingOnly :: Parser FicsMessage
+pieceHoldingOnly = PieceHolding
+ <$> (" game " *> decimal <* " ")
+ <*> ("white [" *> many' dropablePiece <* "] ")
+ <*> ("black [" *> many' dropablePiece <* "]" <* option "" " <-")
+
+
+dropablePiece :: Parser PType
+dropablePiece =
+ "P" *> pure Pawn <|> "R" *> pure Rook <|> "N" *> pure Knight <|>
+ "B" *> pure Bishop <|> "Q" *> pure Queen
+
+
diff --git a/src/Macbeth/Fics/Parsers/Players.hs b/src/Macbeth/Fics/Parsers/Players.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/Players.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.Players (
+ finger,
+ players,
+ history,
+ userHandle,
+ partnerNotOpen,
+ partnerOffer,
+ partnerDeclined,
+ partnerAccepted,
+ players',
+ player'
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Player
+import Macbeth.Fics.Parsers.Api
+import qualified Macbeth.Fics.Parsers.RatingParser as RP
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+
+
+players :: Parser FicsMessage
+players = Players <$> (commandHead 146 *> players')
+
+
+partnerNotOpen :: Parser FicsMessage
+partnerNotOpen = PartnerNotOpen <$> (commandHead 84 *> userHandle <* " is not open for bughouse.")
+
+partnerOffer :: Parser FicsMessage
+partnerOffer = PartnerOffer <$> (userHandle <* " offers to be your bughouse partner")
+
+partnerDeclined :: Parser FicsMessage
+partnerDeclined = PartnerDeclined <$> (userHandle <* " declines the partnership request.")
+
+partnerAccepted :: Parser FicsMessage
+partnerAccepted = PartnerAccepted <$> (userHandle <* " agrees to be your partner.")
+
+finger :: Parser FicsMessage
+finger = Finger
+ <$> (commandHead 37 *> "Finger of " *> userHandle <* ":")
+ <*> manyTill anyChar "\ETB"
+
+
+history :: Parser FicsMessage
+history = history' <|> emptyHistory
+
+
+history' :: Parser FicsMessage
+history' = History
+ <$> (commandHead 51 *> "\nHistory for " *> userHandle <* ":")
+ <*> manyTill anyChar "\ETB"
+
+
+emptyHistory :: Parser FicsMessage
+emptyHistory = do
+ userHandle <- commandHead 51 *> userHandle <* " has no history games."
+ return $ History userHandle (name userHandle ++ " has no history games.\n")
+
+
+players' :: Parser [Player]
+players' = concat <$> sepBy (many' (player' <* many " ")) "\n"
+
+
+player' :: Parser Player
+player' = Player
+ <$> RP.rating
+ <*> status'
+ <*> userHandle
+
+
+status' :: Parser Status
+status' =
+ "^" *> pure InvolvedInAGame <|>
+ "~" *> pure RunningASimulMatch <|>
+ ":" *> pure NotOpenForMatch <|>
+ "#" *> pure ExaminingAGame <|>
+ "." *> pure InactiveOrBusy <|>
+ " " *> pure NotBusy <|>
+ "&" *> pure InvolvedInATournament
+
+
+userHandle :: Parser UserHandle
+userHandle = UserHandle
+ <$> many1' letter_ascii
+ <*> option [] (many handleType')
+
+
+handleType' :: Parser HandleType
+handleType' =
+ "(*)" *> pure Admin <|>
+ "(B)" *> pure Blindfold <|>
+ "(C)" *> pure Computer <|>
+ "(D)" *> pure NOT_DOCUMENTED <|>
+ "(T)" *> pure Team <|>
+ "(U)" *> pure Unregistered <|>
+ "(CA)" *> pure ChessAdvisor <|>
+ "(SR)" *> pure ServiceRepresentative <|>
+ "(TD)" *> pure ServiceRepresentative <|>
+ "(TM)" *> pure MamerManager <|>
+ "(GM)" *> pure GrandMaster <|>
+ "(IM)" *> pure InternationalMaster <|>
+ "(FM)" *> pure FideMaster <|>
+ "(WGM)" *> pure WomenGrandMaster <|>
+ "(WIM)" *> pure WomenInternationalMaster <|>
+ "(WFM)" *> pure WomenFideMaster
+
diff --git a/src/Macbeth/Fics/Parsers/PositionParser.hs b/src/Macbeth/Fics/Parsers/PositionParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/PositionParser.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.PositionParser (
+ parsePosition
+) where
+
+import Macbeth.Fics.Api.Api
+import Control.Arrow (second)
+import Data.List.Split
+import Data.Maybe
+
+
+parsePosition :: String -> [(Square, Piece)]
+parsePosition str = fmap (second fromJust) $ filter (\(_,p) -> isJust p) squares
+ where rows = parseRows str
+ squares = concat $ fmap parseSquares rows
+
+parseRows :: String -> [(Row, String)]
+parseRows str = zip rows lines
+ where rows = [Eight, Seven .. One]
+ lines = splitOn " " str
+
+
+parseColumn :: String -> [(Column, Maybe Piece)]
+parseColumn line = zip [A .. H] [readPiece c | c <- line]
+
+
+parseSquares :: (Row, String) -> [(Square, Maybe Piece)]
+parseSquares (r, line) = fmap (\cc -> (Square (fst cc) r, snd cc)) (parseColumn line)
+
+
+readPiece :: Char -> Maybe Piece
+readPiece 'P' = Just(Piece Pawn White)
+readPiece 'R' = Just(Piece Rook White)
+readPiece 'N' = Just(Piece Knight White)
+readPiece 'B' = Just(Piece Bishop White)
+readPiece 'Q' = Just(Piece Queen White)
+readPiece 'K' = Just(Piece King White)
+readPiece 'p' = Just(Piece Pawn Black)
+readPiece 'r' = Just(Piece Rook Black)
+readPiece 'n' = Just(Piece Knight Black)
+readPiece 'b' = Just(Piece Bishop Black)
+readPiece 'q' = Just(Piece Queen Black)
+readPiece 'k' = Just(Piece King Black)
+readPiece _ = Nothing
diff --git a/src/Macbeth/Fics/Parsers/RatingParser.hs b/src/Macbeth/Fics/Parsers/RatingParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/RatingParser.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.RatingParser (
+ rating
+) where
+
+import Macbeth.Fics.Api.Rating
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+
+rating :: Parser Rating
+rating = (Rating <$> decimal <*> pure None) <|> "++++" *> pure Guest <|> "----" *> pure Unrated
diff --git a/src/Macbeth/Fics/Parsers/SeekMsgParsers.hs b/src/Macbeth/Fics/Parsers/SeekMsgParsers.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Parsers/SeekMsgParsers.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Macbeth.Fics.Parsers.SeekMsgParsers (
+ clearSeek,
+ newSeek,
+ removeSeeks,
+ seekNotAvailable
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.Api.Rating
+import Macbeth.Fics.Api.Seek
+import Macbeth.Fics.Parsers.Api
+import Macbeth.Fics.Utils.Bitmask
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+import Numeric
+
+clearSeek :: Parser FicsMessage
+clearSeek = "" *> pure ClearSeek
+
+newSeek :: Parser FicsMessage
+newSeek = NewSeek <$> seek'
+
+removeSeeks :: Parser FicsMessage
+removeSeeks = RemoveSeeks <$> ("" *> many1 (space *> decimal))
+
+seekNotAvailable :: Parser FicsMessage
+seekNotAvailable = commandHead 158 *> "That seek is not available." *> pure SeekNotAvailable
+
+seek' :: Parser Seek
+seek' = Seek
+ <$> ("" *> space *> decimal)
+ <*> (space *> "w=" *> manyTill anyChar space)
+ <*> ("ti=" *> titles')
+ <*> ("rt=" *> rating')
+ <*> (space *> "t=" *> decimal)
+ <*> (space *> "i=" *> decimal)
+ <*> (space *> "r=" *> ("r" *> pure True <|> "u" *> pure False))
+ <*> (space *> "tp=" *> gameType')
+ <*> (space *> "c=" *> ("W" *> pure (Just White) <|>
+ "B" *> pure (Just Black) <|>
+ "?" *> pure Nothing))
+ <*> (space *> "rr=" *> ((,) <$> decimal <*> ("-" *> decimal)))
+
+gameType' :: Parser GameType
+gameType' =
+ "blitz" *> pure Blitz <|>
+ "lightning" *> pure Lightning <|>
+ "untimed" *> pure Untimed <|>
+ "examined" *> pure ExaminedGame <|>
+ "standard" *> pure Standard <|>
+ "wild/" *> decimal *> pure Wild <|>
+ "atomic" *> pure Atomic <|>
+ "crazyhouse" *> pure Crazyhouse <|>
+ "bughouse" *> pure Bughouse <|>
+ "losers" *> pure Losers <|>
+ "suicide" *> pure Suicide <|>
+ takeTill (== ' ') *> pure NonStandardGame
+
+
+rating' :: Parser Rating
+rating' = Rating <$> decimal <*> provShow'
+
+
+provShow' :: Parser ProvShow
+provShow' = " " *> pure None <|>
+ "E" *> pure Estimated <|>
+ "P" *> pure Provisional
+
+
+titles' :: Parser [Title]
+titles' = manyTill anyChar space >>= pure . fromBitMask . fst . head . readHex
diff --git a/src/Macbeth/Fics/Utils/Bitmask.hs b/src/Macbeth/Fics/Utils/Bitmask.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Fics/Utils/Bitmask.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE DefaultSignatures #-}
+module Macbeth.Fics.Utils.Bitmask (
+ ToBitMask (..),
+ fromBitMask,
+ isInBitMask
+) where
+
+import Control.Monad
+import Data.Bits
+{-
+ Thank you Nikita Volkov
+ http://stackoverflow.com/questions/15910363/represent-a-list-of-enums-bitwise-as-an-int
+-}
+class ToBitMask a where
+ toBitMask :: a -> Int
+ -- | Using a DefaultSignatures extension to declare a default signature with
+ -- an `Enum` constraint without affecting the constraints of the class itself.
+ default toBitMask :: Enum a => a -> Int
+ toBitMask = shiftL 1 . fromEnum
+
+instance ( ToBitMask a ) => ToBitMask [a] where
+ toBitMask = foldr (.|.) 0 . map toBitMask
+
+-- | Not making this a typeclass, since it already generalizes over all
+-- imaginable instances with help of `MonadPlus`.
+fromBitMask ::
+ ( MonadPlus m, Enum a, Bounded a, ToBitMask a ) =>
+ Int -> m a
+fromBitMask bm = msum $ map asInBM $ enumFrom minBound where
+ asInBM a = if isInBitMask bm a then return a else mzero
+
+isInBitMask :: ( ToBitMask a ) => Int -> a -> Bool
+isInBitMask bm a = let aBM = toBitMask a in aBM == aBM .&. bm
+
diff --git a/src/Macbeth/Utils/BoardUtils.hs b/src/Macbeth/Utils/BoardUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Utils/BoardUtils.hs
@@ -0,0 +1,85 @@
+module Macbeth.Utils.BoardUtils (
+ drawArrow,
+ squareToRect',
+ toPos',
+ pieceToBitmap
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Wx.PieceSet
+import Paths
+
+import Graphics.UI.WX
+import System.FilePath
+import System.IO.Unsafe
+
+
+rowToInt :: Macbeth.Fics.Api.Api.PColor -> Row -> Int
+rowToInt White = abs . (7-) . fromEnum
+rowToInt Black = fromEnum
+
+
+colToInt :: Macbeth.Fics.Api.Api.PColor -> Column -> Int
+colToInt White = fromEnum
+colToInt Black = abs . (7-) . fromEnum
+
+
+toPos' :: Int -> Square -> PColor -> Point
+toPos' size (Square c r) color = point (colToInt color c * size) (rowToInt color r * size)
+
+
+squareToRect' :: Int -> Square -> PColor -> Rect
+squareToRect' size sq color = Rect pointX' pointY' size size
+ where pointX' = pointX $ toPos' size sq color
+ pointY' = pointY $ toPos' size sq color
+
+
+drawArrow dc size s1 s2 perspective =
+ drawArrowPt dc (pt (x1+size_half) (y1+size_half)) (pt (x2'+size_half) (y2'+size_half))
+ where (Rect x1 y1 _ _ ) = squareToRect' size s1 perspective
+ (Rect x2 y2 _ _ ) = squareToRect' size s2 perspective
+ size_half = round $ fromIntegral size / 2
+ x2'
+ | x2 > x1 = x2 - size_half
+ | x2 < x1 = x2 + size_half
+ | otherwise = x2
+ y2'
+ | y2 > y1 = y2 - size_half
+ | y2 < y1 = y2 + size_half
+ | otherwise = y2
+
+drawArrowPt dc p1 p2 = do
+ line dc p1 p2 []
+ polygon dc (fmap (movePt (pointX p2) (pointY p2) . rotate (dfix-90)) triangle) []
+ where
+ triangle = [(0, 0), (-2, -7), (2, -7)]
+ movePt x y (Point px py) = pt (x + px) (y + py)
+ deltaX = pointX p2 - pointX p1
+ deltaY = pointY p2 - pointY p1
+ d = atan(fromIntegral deltaY / fromIntegral deltaX) * 180 / pi
+ dfix = if deltaX < 0 then d -180 else d
+
+
+rotate :: Double -> (Int, Int) -> Point
+rotate d ptx = pt (round $ x * cos rad - y * sin rad) (round $ x * sin rad + y * cos rad)
+ where x = fromIntegral $ fst ptx
+ y = fromIntegral $ snd ptx
+ rad = d/180*pi
+
+
+pieceToBitmap :: Int -> PieceSet -> Piece -> Bitmap ()
+pieceToBitmap size pieceSet p = bitmap $ unsafePerformIO $ getDataFileName $ path pieceSet show size pieceToFile p ++ ".png"
+ where
+ pieceToFile :: Piece -> String
+ pieceToFile (Piece King Black) = "bk"
+ pieceToFile (Piece Queen Black) = "bq"
+ pieceToFile (Piece Rook Black) = "br"
+ pieceToFile (Piece Knight Black) = "bn"
+ pieceToFile (Piece Bishop Black) = "bb"
+ pieceToFile (Piece Pawn Black) = "bp"
+ pieceToFile (Piece King White) = "wk"
+ pieceToFile (Piece Queen White) = "wq"
+ pieceToFile (Piece Rook White) = "wr"
+ pieceToFile (Piece Knight White) = "wn"
+ pieceToFile (Piece Bishop White) = "wb"
+ pieceToFile (Piece Pawn White) = "wp"
diff --git a/src/Macbeth/Utils/FEN.hs b/src/Macbeth/Utils/FEN.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Utils/FEN.hs
@@ -0,0 +1,54 @@
+module Macbeth.Utils.FEN (
+ available,
+ convert
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Move
+
+import Data.List.Utils
+
+
+convert :: Move -> String
+convert m = piecePlacement (positionRaw m) ++ " " ++
+ activeColor (turn m) ++ " " ++
+ castlingAv' (castlingAv m) ++ " " ++
+ enPassant (turn m) (doublePawnPush m) ++ " " ++
+ show (ply m) ++ " " ++
+ show (moveNumber m)
+
+available :: Move -> Bool
+available m
+ | moveNumber m == 1 && turn m == Black = False
+ | otherwise = True
+
+enPassant :: PColor -> Maybe Column -> String
+enPassant Black (Just c) = show $ Square c Three
+enPassant White (Just c) = show $ Square c Six
+enPassant _ _ = "-"
+
+
+castlingAv' :: [Castling] -> String
+castlingAv' [] = "-"
+castlingAv' cx = concat $ fmap castlingToStr cx
+
+
+castlingToStr WhiteLong = "Q"
+castlingToStr WhiteShort = "K"
+castlingToStr BlackLong = "q"
+castlingToStr BlackShort = "k"
+
+
+activeColor :: PColor -> String
+activeColor White = "w"
+activeColor Black = "b"
+
+
+piecePlacement :: String -> String
+piecePlacement = replace " " "/" . emptySquares 8
+
+
+emptySquares :: Int -> String -> String
+emptySquares num str
+ | num == 0 = str
+ | otherwise = emptySquares (num-1) (replace (replicate num '-') (show num) str)
diff --git a/src/Macbeth/Utils/PGN.hs b/src/Macbeth/Utils/PGN.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Utils/PGN.hs
@@ -0,0 +1,66 @@
+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
diff --git a/src/Macbeth/Utils/Utils.hs b/src/Macbeth/Utils/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Utils/Utils.hs
@@ -0,0 +1,22 @@
+module Macbeth.Utils.Utils (
+ formatTime
+) where
+
+import Control.Monad.State
+
+formatTime :: Int -> String
+formatTime seconds = show h ++ " : " ++ format m ++ " : " ++ format s
+ where
+ (_, (h,m,s)) = runState (calc seconds) (0,0,0)
+
+
+calc :: Int -> State (Int, Int, Int) Int
+calc seconds
+ | seconds >= 3600 = get >>= \(h, m, s) -> put (h+1, m, s) >> calc (seconds - 3600)
+ | seconds >= 60 = get >>= \(h, m, s) -> put (h, m+1, s) >> calc (seconds - 60)
+ | otherwise = get >>= \(h, m, _) -> put (h, m, max 0 seconds) >> return 0
+
+format :: Int -> String
+format i
+ | i < 10 = "0" ++ show i
+ | otherwise = show i
diff --git a/src/Macbeth/Wx/Board.hs b/src/Macbeth/Wx/Board.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Board.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Macbeth.Wx.Board (
+ draw,
+ onMouseEvent
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Move
+import Macbeth.Utils.BoardUtils
+import Macbeth.Wx.BoardState
+
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+import Data.Maybe
+import Control.Concurrent.STM
+import Graphics.UI.WX hiding (position, update, resize, when)
+import Graphics.UI.WXCore hiding (Row, Column, when)
+import System.IO
+
+type BoardT a = ReaderT (DC a, BoardState) IO ()
+
+draw :: TVar BoardState -> DC a -> t -> IO ()
+draw vState dc _ = do
+ state <- readTVarIO vState
+ flip runReaderT (dc, state) $ do
+ setScale
+ drawBoard
+ drawHighlightLastMove
+ drawHighlightPreMove
+ drawPieces
+ drawSelectedSquare
+ drawDraggedPiece
+
+
+setScale :: BoardT a
+setScale = do
+ (dc, state) <- ask
+ liftIO $ dcSetUserScale dc (scale state) (scale state)
+
+
+drawBoard :: BoardT a
+drawBoard = do
+ (dc, state) <- ask
+ let perspective' = perspective state
+ let bw = concat $ replicate 4 (concat $ replicate 4 seed ++ replicate 4 (reverse seed))
+ where seed = if perspective' == White then [Black, White] else [White, Black]
+ let sq = [Square c r | c <- [A .. H], r <- [One .. Eight]]
+ lift $ set dc [ pen := penTransparent ]
+ lift $ withBrushStyle (BrushStyle BrushSolid (rgb (180::Int) 150 100)) $ \blackBrush ->
+ withBrushStyle (BrushStyle BrushSolid white) $ \whiteBrush ->
+ mapM_ (\(c,sq) -> do
+ dcSetBrush dc $ if c == White then whiteBrush else blackBrush
+ paintSquare dc state sq)
+ (zip (if perspective' == White then bw else reverse bw) sq)
+
+
+drawHighlightLastMove :: BoardT a
+drawHighlightLastMove = do
+ (dc, state) <- ask
+ liftIO $ when (isHighlightMove $ lastMove state) $
+ sequence_ $ paintHighlight dc state blue `fmap` pieceMove state
+ where
+ isHighlightMove :: Move -> Bool
+ isHighlightMove m = (isJust . moveVerbose) m && (wasOponentMove m || relation m == Observing)
+
+
+drawHighlightPreMove :: BoardT a
+drawHighlightPreMove = do
+ (dc, state) <- ask
+ liftIO $ sequence_ $ paintHighlight dc state yellow `fmap` preMoves state
+
+
+drawPieces :: BoardT a
+drawPieces = do
+ (dc, state) <- ask
+ liftIO $ sequence_ $ drawPiece dc state `fmap` _position state
+ where
+ drawPiece :: DC a -> BoardState -> (Square, Piece) -> IO ()
+ drawPiece dc state (sq, p) = drawBitmap dc
+ (pieceToBitmap (psize state) (pieceSet state) p)
+ (toPos' (psize state) sq (perspective state)) True []
+
+
+drawSelectedSquare :: BoardT a
+drawSelectedSquare = do
+ (dc, state) <- ask
+ liftIO $ when (isGameUser (lastMove state) && isNothing (gameResult state)) $
+ withBrushStyle brushTransparent $ \transparent -> do
+ dcSetBrush dc transparent
+ set dc [pen := penColored red 1]
+ paintSquare dc state (getSelectedSquare state)
+
+
+drawDraggedPiece :: BoardT a
+drawDraggedPiece = do
+ (dc, state) <- ask
+ case draggedPiece state of
+ Just dp -> liftIO $ drawDraggedPiece'' state dc dp
+ _ -> return ()
+
+
+drawDraggedPiece'' :: BoardState -> DC a -> DraggedPiece -> IO ()
+drawDraggedPiece'' state dc (DraggedPiece pt piece _) = drawBitmap dc (pieceToBitmap size (pieceSet state) piece) (scalePoint pt) True []
+ where
+ scale' = scale state
+ size = psize state
+ scalePoint pt = point (scaleValue $ pointX pt) (scaleValue $ pointY pt)
+ scaleValue value = round $ (fromIntegral value - fromIntegral size / 2 * scale') / scale'
+
+
+paintHighlight :: DC a -> BoardState -> Color -> PieceMove -> IO ()
+paintHighlight dc state color (PieceMove _ s1 s2) = do
+ set dc [pen := penColored color 1]
+ withBrushStyle (BrushStyle (BrushHatch HatchBDiagonal) color) $ \brushBg -> do
+ dcSetBrush dc brushBg
+ mapM_ (paintSquare dc state) [s1, s2]
+ withBrushStyle (BrushStyle BrushSolid color) $ \brushArrow -> do
+ dcSetBrush dc brushArrow
+ drawArrow dc (psize state) s1 s2 (perspective state)
+paintHighlight dc state color (DropMove _ s1) = do
+ set dc [pen := penColored color 1]
+ withBrushStyle (BrushStyle (BrushHatch HatchBDiagonal) color) $ \brushBg -> do
+ dcSetBrush dc brushBg
+ paintSquare dc state s1
+
+
+paintSquare :: DC a -> BoardState -> Square -> IO ()
+paintSquare dc state sq = drawRect dc (squareToRect' (psize state) sq (perspective state)) []
+
+
+onMouseEvent :: Handle -> Var BoardState -> EventMouse -> IO ()
+onMouseEvent h vState = \case
+
+ MouseMotion pt _ -> updateMousePosition vState pt
+
+ MouseLeftDown pt _ -> do
+ dp <- draggedPiece `fmap` readTVarIO vState
+ if isJust dp then dropDraggedPiece vState h pt else pickUpPiece vState pt
+
+ MouseLeftUp click_pt _ -> dropDraggedPiece vState h click_pt
+
+ MouseLeftDrag pt _ -> updateMousePosition vState pt
+
+ _ -> return ()
+
+
+updateMousePosition :: TVar BoardState -> Point -> IO ()
+updateMousePosition vState pt = atomically $ modifyTVar vState
+ (\s -> s{ mousePt = pt, draggedPiece = draggedPiece s >>= setNewPoint pt})
+ where
+ setNewPoint :: Point -> DraggedPiece -> Maybe DraggedPiece
+ setNewPoint pt (DraggedPiece _ p o) = Just (DraggedPiece pt p o)
+
+
+dropDraggedPiece :: TVar BoardState -> Handle -> Point -> IO ()
+dropDraggedPiece vState h click_pt = do
+ state <- readTVarIO vState
+ void $ runMaybeT $ do
+ dp <- MaybeT $ return (draggedPiece state)
+ let pieceMove = toPieceMove (pointToSquare state click_pt) dp
+ let newPosition = movePiece pieceMove (_position state)
+ liftIO $ do
+ varSet vState state { _position = newPosition, draggedPiece = Nothing}
+ if isWaiting state
+ then hPutStrLn h $ "6 " ++ show pieceMove
+ else addPreMove vState pieceMove
+ where
+ toPieceMove :: Square -> DraggedPiece -> PieceMove
+ toPieceMove toSq (DraggedPiece _ piece (FromBoard fromSq)) = PieceMove piece fromSq toSq
+ toPieceMove toSq (DraggedPiece _ piece FromHolding) = DropMove piece toSq
+
+ addPreMove :: TVar BoardState -> PieceMove -> IO ()
+ addPreMove vState pm = atomically $ modifyTVar vState (\s -> s {preMoves = preMoves s ++ [pm]})
+
+
+pickUpPiece :: TVar BoardState -> Point -> IO ()
+pickUpPiece vState pt = do
+ state <- readTVarIO vState
+ let square' = pointToSquare state pt
+ case getPiece (_position state) square' (colorUser $ lastMove state) of
+ Just piece -> varSet vState state { _position = removePiece (_position state) square'
+ , draggedPiece = Just $ DraggedPiece pt piece $ FromBoard square'}
+ _ -> return ()
+ where
+ removePiece :: Position -> Square -> Position
+ removePiece pos sq = filter (\(sq', _) -> sq /= sq') pos
+
+ getPiece :: Position -> Square -> PColor -> Maybe Piece
+ getPiece pos sq color = sq `lookup` pos >>= checkColor color
+ where
+ checkColor :: PColor -> Piece -> Maybe Piece
+ checkColor c p@(Piece _ c') = if c == c' then Just p else Nothing
+
diff --git a/src/Macbeth/Wx/BoardState.hs b/src/Macbeth/Wx/BoardState.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/BoardState.hs
@@ -0,0 +1,222 @@
+module Macbeth.Wx.BoardState (
+ BoardState(..),
+ DraggedPiece(..),
+ Origin(..),
+ PieceMove (..),
+
+ pickUpPieceFromHolding,
+ discardDraggedPiece,
+
+ setPromotion,
+ togglePromotion,
+
+ pointToSquare,
+ movePiece,
+
+ update,
+ setResult,
+ resize,
+ invertPerspective,
+
+ performPreMoves,
+ cancelLastPreMove,
+
+ setPieceSet,
+ getPieceHolding,
+
+ getSelectedSquare,
+ initBoardState
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Move
+import Macbeth.Fics.Api.Game
+import Macbeth.Wx.PieceSet
+
+import Control.Monad
+import Control.Concurrent.STM
+import Data.Maybe
+import Data.List
+import Graphics.UI.WX hiding (position, update, resize, when)
+import Safe
+import System.IO
+
+
+data BoardState = BoardState {
+ lastMove :: Move
+ , gameResult :: Maybe GameResult
+ , pieceMove :: [PieceMove]
+ , moves :: [Move]
+ , _position :: Position
+ , preMoves :: [PieceMove]
+ , perspective :: PColor
+ , mousePt :: Point
+ , promotion :: PType
+ , draggedPiece :: Maybe DraggedPiece
+ , isWaiting :: Bool
+ , psize :: Int
+ , scale :: Double
+ , pieceSet :: PieceSet
+ , phW :: [PType]
+ , phB :: [PType] }
+
+
+data DraggedPiece = DraggedPiece Point Piece Origin deriving (Show)
+
+data Origin = FromHolding | FromBoard Square deriving (Show)
+
+data PieceMove = PieceMove { piece :: Piece, from :: Square, to :: Square } | DropMove Piece Square
+
+instance Show PieceMove where
+ show (PieceMove _ s1 s2) = show s1 ++ show s2
+ show (DropMove (Piece p _) s) = show p ++ "@" ++ show s
+
+
+pickUpPieceFromHolding :: TVar BoardState -> PType -> IO ()
+pickUpPieceFromHolding vState p = atomically $ modifyTVar vState
+ (\s -> let color = colorUser (lastMove s)
+ isAllowed = isGameUser (lastMove s) && p `elem` getPieceHolding color s
+ in if isAllowed
+ then s{draggedPiece = Just $ DraggedPiece (mousePt s) (Piece p color) FromHolding }
+ else s)
+
+
+discardDraggedPiece :: TVar BoardState -> IO ()
+discardDraggedPiece vState = atomically $ modifyTVar vState (\s -> s {
+ draggedPiece = Nothing
+ , _position = movePieces (preMoves s) (position $ lastMove s)})
+
+
+invertPerspective :: TVar BoardState -> IO ()
+invertPerspective vState = atomically $ modifyTVar vState (\s -> s{perspective = invert $ perspective s})
+
+
+setResult :: TVar BoardState -> GameResult -> IO ()
+setResult vState r = atomically $ modifyTVar vState (\s -> s{
+ gameResult = Just r
+ , _position = position $ lastMove s
+ , preMoves = []
+ , draggedPiece = Nothing})
+
+
+setPromotion :: PType -> TVar BoardState -> IO ()
+setPromotion p vState = atomically $ modifyTVar vState (\s -> s{promotion = p})
+
+
+togglePromotion :: TVar BoardState -> IO PType
+togglePromotion vState = atomically $ do
+ modifyTVar vState (\s -> s{promotion = togglePromotion' (promotion s)})
+ promotion `fmap` readTVar vState
+ where
+ togglePromotion' :: PType -> PType
+ togglePromotion' p = let px = [Queen, Rook, Knight, Bishop]
+ in px !! ((fromJust (p `elemIndex` px) + 1) `mod` length px)
+
+
+update :: TVar BoardState -> Move -> MoveModifier -> IO ()
+update vBoardState move ctx = atomically $ modifyTVar vBoardState (\s -> s {
+ isWaiting = isNextMoveUser move
+ , pieceMove = diffPosition (position $ lastMove s) (position move)
+ , moves = addtoHistory move ctx (moves s)
+ , lastMove = move
+ , _position = movePieces (preMoves s) (position move)})
+
+
+diffPosition :: Position -> Position -> [PieceMove]
+diffPosition before after =
+ let from = before \\ after
+ to = after \\ before
+ in [PieceMove piece1 s1 s2 | (s1, piece1) <- from, (s2, piece2) <- to, piece1 == piece2, s1 /= s2 ]
+
+
+addtoHistory :: Move -> MoveModifier -> [Move] -> [Move]
+addtoHistory _ Illegal mx = mx
+addtoHistory m (Takeback _) mx = m : tail (dropWhile (not . equal m) mx)
+ where
+ equal :: Move -> Move -> Bool
+ equal m1 m2 = (moveNumber m1 == moveNumber m2) && (turn m1 == turn m2)
+addtoHistory m _ mx = m : mx
+
+
+resize :: Panel () -> TVar BoardState -> IO ()
+resize p vState = do
+ (Size x _) <- get p size
+ let psize' = pieceSetFindSize x
+ atomically $ modifyTVar vState (\s -> s { psize = psize', scale = fromIntegral x / 8 / fromIntegral psize'})
+
+
+cancelLastPreMove :: TVar BoardState -> IO ()
+cancelLastPreMove vBoardState = atomically $ modifyTVar vBoardState (\s ->
+ let preMoves' = fromMaybe [] $ initMay (preMoves s) in s {
+ preMoves = preMoves'
+ , _position = movePieces preMoves' (position $ lastMove s)})
+
+
+performPreMoves :: TVar BoardState -> Handle -> IO ()
+performPreMoves vBoardState h = do
+ preMoves' <- preMoves `fmap` readTVarIO vBoardState
+ unless (null preMoves') $ do
+ atomically $ modifyTVar vBoardState (\s -> s {
+ isWaiting = False,
+ preMoves = tail preMoves'})
+ hPutStrLn h $ "6 " ++ show (head preMoves' )
+
+
+setPieceSet :: TVar BoardState -> PieceSet -> IO ()
+setPieceSet vState ps = atomically (modifyTVar vState (\s -> s { pieceSet = ps }))
+
+
+getPieceHolding :: PColor -> BoardState -> [PType]
+getPieceHolding White bs = phW bs
+getPieceHolding Black bs = phB bs
+
+
+getSelectedSquare :: BoardState -> Square
+getSelectedSquare state = pointToSquare state (mousePt state)
+
+
+pointToSquare :: BoardState -> Point -> Square
+pointToSquare state (Point x y) = Square
+ (intToCol (perspective state) (floor $ fromIntegral x / fieldSize state))
+ (intToRow (perspective state) (floor $ fromIntegral y / fieldSize state))
+ where
+ intToRow :: PColor -> Int -> Row
+ intToRow White = toEnum . abs . (7-)
+ intToRow Black = toEnum
+
+ intToCol :: PColor -> Int -> Column
+ intToCol White = toEnum
+ intToCol Black = toEnum . abs . (7-)
+
+ fieldSize :: BoardState -> Double
+ fieldSize bs = scale bs * fromIntegral (psize bs)
+
+
+movePieces :: [PieceMove] -> Position -> Position
+movePieces moves pos = foldl (flip movePiece) pos moves
+
+
+movePiece :: PieceMove -> Position -> Position
+movePiece (PieceMove piece from to) position = filter (\(s, _) -> s /= from && s /= to) position ++ [(to, piece)]
+movePiece (DropMove piece sq) pos = filter (\(s, _) -> s /= sq) pos ++ [(sq, piece)]
+
+
+initBoardState :: Move -> BoardState
+initBoardState move = BoardState {
+ lastMove = move
+ , gameResult = Nothing
+ , pieceMove = []
+ , moves = [move] -- ^ accept empty positions, filter when creating pgn
+ , _position = Macbeth.Fics.Api.Move.position move
+ , preMoves = []
+ , perspective = if relation move == Observing then White else colorUser move
+ , mousePt = Point 0 0
+ , promotion = Queen
+ , draggedPiece = Nothing
+ , isWaiting = relation move == MyMove
+ , psize = 40
+ , scale = 1.0
+ , pieceSet = head pieceSets
+ , phW = []
+ , phB = []}
+
diff --git a/src/Macbeth/Wx/Challenge.hs b/src/Macbeth/Wx/Challenge.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Challenge.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Macbeth.Wx.Challenge (
+ wxChallenge
+) where
+
+import Macbeth.Fics.Api.Challenge
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.Utils
+
+import Control.Concurrent
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+import System.IO
+
+
+wxChallenge :: Handle -> Challenge -> Chan FicsMessage -> IO ()
+wxChallenge h c chan = do
+ vCmd <- newEmptyMVar
+
+ f <- frame []
+ p <- panel f []
+
+ b_accept <- button p [text := "Accept", on command := hPutStrLn h "5 accept" >> close f]
+ b_decline <- button p [text := "Decline", on command := hPutStrLn h "5 decline" >> close f]
+ st_params <- staticText p [ text := displayChallenge c
+ , fontFace := "Avenir Next Medium"
+ , fontSize := 16
+ , fontWeight := WeightBold]
+
+ set f [ defaultButton := b_accept
+ , layout := container p $ margin 10 $
+ column 5 [boxed "You received a challenge." (
+ grid 5 5 [
+ [ hfill $ widget st_params]]
+ )
+ , floatBottomRight $ row 5 [widget b_accept, widget b_decline]]
+ ]
+
+ evtHandlerOnMenuCommand f eventId $ takeMVar vCmd >>= \case
+
+ MatchRequested c' -> when (isUpdate c c') $ close f
+
+ WxClose -> close f
+
+ _ -> return ()
+
+ threadId <- forkIO $ eventLoop eventId chan vCmd f
+ windowOnDestroy f $ killThread threadId
+
+
+isUpdate :: Challenge -> Challenge -> Bool
+isUpdate c c' = (nameW c == nameW c') && (nameB c == nameB c')
+
+eventId = wxID_HIGHEST + 1
diff --git a/src/Macbeth/Wx/Configuration.hs b/src/Macbeth/Wx/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Configuration.hs
@@ -0,0 +1,56 @@
+module Macbeth.Wx.Configuration (
+ wxConfiguration
+) where
+
+import Macbeth.Fics.Configuration
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.Utils
+
+import Control.Concurrent.Chan
+import Control.Monad
+import Control.Monad.Except
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Yaml as Y
+
+wxConfiguration :: Chan FicsMessage -> IO ()
+wxConfiguration chan = do
+ f <- frame [ text := "Macbeth"]
+ ct <- textCtrlEx f (wxTE_MULTILINE .+. wxTE_RICH) [font := fontFixed]
+ showConfig ct loadConfig
+ status <- statusField []
+
+ b_default <- button f [text := "Default", on command := showConfig ct loadDefaultConfig]
+ b_current <- button f [text := "Current", on command := showConfig ct loadConfig]
+ b_save <- button f [ text := "Save",
+ on command := void $ runExceptT $ parseAndSave ct status `catchError` showError status]
+
+
+ set f [ statusBar := [status],
+ layout := margin 10 $ column 10 [
+ boxed "Configuration" $ fill $ minsize (Size 380 220) $ widget ct
+ , hfloatRight $ row 5 [widget b_default, widget b_current, widget b_save]]
+ ]
+ registerWxCloseEventListener f chan
+
+showConfig :: TextCtrl() -> IO Config -> IO ()
+showConfig ct io_config = io_config >>= \config -> set ct [text := comments ++ BS.unpack (Y.encode config)]
+
+
+parseAndSave :: TextCtrl () -> StatusField -> ExceptT Y.ParseException IO ()
+parseAndSave ct status = do
+ config <- ExceptT $ (Y.decodeEither' . BS.pack) `fmap` get ct text
+ liftIO $ saveConfig config
+ liftIO $ set status [text := "Configuration saved."]
+
+
+showError :: StatusField -> Y.ParseException -> ExceptT Y.ParseException IO ()
+showError status _ = liftIO $ set status [text := "Illegal file format."]
+
+
+comments :: String
+comments = "# Changes will take effect only after restart (for now).\n\n\
+ \# If you change the directory make sure it exists.\n\
+ \# It will not be created for you.\n\n"
diff --git a/src/Macbeth/Wx/Finger.hs b/src/Macbeth/Wx/Finger.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Finger.hs
@@ -0,0 +1,30 @@
+module Macbeth.Wx.Finger (
+ wxInfo
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Player
+import Macbeth.Wx.Utils
+
+import Control.Concurrent.Chan
+import Graphics.UI.WX
+
+wxInfo :: FicsMessage -> Chan FicsMessage -> IO ()
+wxInfo msg chan = do
+ f <- frameFixed [ text := title msg]
+ st <- staticText f [ text := showAll msg
+ , font := fontFixed
+ , fontSize := 14]
+ set f [layout := margin 10 $ row 0 [widget st]]
+ registerWxCloseEventListener f chan
+
+title :: FicsMessage -> String
+title (Finger userHandle _) = "Finger of " ++ name userHandle
+title (History userHandle _) = "History for " ++ name userHandle
+title _ = ""
+
+
+showAll :: FicsMessage -> String
+showAll m@(Finger _ msg) = title m ++ msg
+showAll m@(History _ msg) = title m ++ "\n" ++ msg
+showAll _ = ""
diff --git a/src/Macbeth/Wx/Game.hs b/src/Macbeth/Wx/Game.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Game.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Macbeth.Wx.Game (
+ wxGame
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.FicsMessage hiding (gameId, Observing)
+import Macbeth.Fics.Api.Move
+import Macbeth.Utils.PGN
+import qualified Macbeth.Wx.BoardState as Api
+import Macbeth.Wx.Utils
+import Macbeth.Wx.PieceSet
+import Macbeth.Wx.StatusPanel
+import qualified Macbeth.Wx.Board as Board
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import Data.Maybe
+import Graphics.UI.WX hiding (when, position)
+import Graphics.UI.WXCore hiding (when, Timer)
+import System.IO
+
+eventId = wxID_HIGHEST + 1
+
+wxGame :: Handle -> Move -> Chan FicsMessage -> IO ()
+wxGame h move chan = do
+ vCmd <- newEmptyMVar
+ f <- frame [ text := "[Game " ++ show (gameId move) ++ "] " ++ nameW move ++ " vs " ++ nameB move]
+ p_back <- panel f []
+
+ -- board
+ let boardState = Api.initBoardState move
+ vBoardState <- newTVarIO boardState
+ p_board <- panel p_back [ on paint := Board.draw vBoardState]
+
+ -- player panels
+ (p_white, updateClockW) <- createStatusPanel p_back White vBoardState
+ (p_black, updateClockB) <- createStatusPanel p_back Black vBoardState
+
+ -- layout helper
+ let updateBoardLayoutIO = updateBoardLayout p_back p_board p_white p_black vBoardState >> refit f
+ updateBoardLayoutIO
+
+ -- status line
+ status <- statusField []
+ promotion <- statusField [ statusWidth := 30, text := "=" ++ show (Api.promotion boardState)]
+
+ -- context menu
+ ctxMenu <- menuPane []
+ menuItem ctxMenu [ text := "Turn board", on command :=
+ Api.invertPerspective vBoardState >> updateBoardLayoutIO >> repaint p_board >> resizeFrame f vBoardState p_board]
+ when (isGameUser move) $ do
+ menuLine ctxMenu
+ menuItem ctxMenu [ text := "Request takeback 1", on command := hPutStrLn h "4 takeback 1"]
+ menuItem ctxMenu [ text := "Request takeback 2", on command := hPutStrLn h "4 takeback 2"]
+ menuItem ctxMenu [ text := "Request abort", on command := hPutStrLn h "4 abort"]
+ menuItem ctxMenu [ text := "Offer draw", on command := hPutStrLn h "4 draw" ]
+ menuItem ctxMenu [ text := "Resign", on command := hPutStrLn h "4 resign" ]
+ windowOnMouse p_board True (\pt -> Board.onMouseEvent h vBoardState pt >> repaint p_board)
+ menuLine ctxMenu
+ wxPieceSetsMenu ctxMenu vBoardState p_board
+
+ set p_board [ on clickRight := (\pt -> menuPopup ctxMenu pt p_board) ]
+
+ -- key handler
+ windowOnKeyDown p_board $ onKeyDownHandler h p_board f vBoardState promotion
+ windowOnKeyUp p_board $ onKeyUpHandler vBoardState h promotion
+
+ --set layout
+ set f [ statusBar := [status] ++ [promotion | isGameUser move]
+ , layout := fill $ widget p_back
+ , on resize := resizeFrame f vBoardState p_board]
+
+ -- necessary: after GameResult no more events are handled
+ tiClose <- dupChan chan >>= registerWxCloseEventListenerWithThreadId f
+
+ threadId <- forkIO $ eventLoop eventId chan vCmd f
+ evtHandlerOnMenuCommand f eventId $ takeMVar vCmd >>= \cmd ->
+ updateClockW cmd >> updateClockB cmd >> case cmd of
+
+ GameMove ctx move' -> when (gameId move' == gameId move) $ do
+ set status [text := show ctx]
+ Api.update vBoardState move' ctx
+ when (isNextMoveUser move') $ Api.performPreMoves vBoardState h
+ repaint p_board
+
+ GameResult id reason result -> when (id == gameId move) $ do
+ set status [text := (show result ++ " " ++ reason)]
+ Api.setResult vBoardState result
+ repaint p_board
+ hPutStrLn h "4 iset seekinfo 1"
+ killThread threadId
+
+ DrawRequest -> set status [text := nameOponent move ++ " offered a draw. Accept? (y/n)"]
+
+ DrawRequestDeclined user -> set status [text := user ++ " declines the draw request."]
+
+ AbortRequest user -> set status [text := user ++ " would like to abort the game. Accept? (y/n)"]
+
+ AbortRequestDeclined user -> set status [text := user ++ " declines the abort request."]
+
+ TakebackRequest user numTakeback -> set status [text := user ++ " would like to take back " ++ show numTakeback ++ " half move(s). Accept? (y/n)"]
+
+ PromotionPiece p -> Api.setPromotion p vBoardState >> set promotion [text := "=" ++ show p]
+
+ _ -> return ()
+
+ windowOnDestroy f $ do
+ sequence_ $ fmap (handle (\(_ :: IOException) -> return ()) . killThread) [threadId, tiClose]
+ boardState <- readTVarIO vBoardState
+ when (isGameUser move) $ saveAsPGN boardState
+ unless (isJust $ Api.gameResult boardState) $ case relation move of
+ MyMove -> hPutStrLn h "5 resign"
+ OponentsMove -> hPutStrLn h "5 resign"
+ Observing -> hPutStrLn h $ "5 unobserve " ++ show (gameId move)
+ _ -> return ()
+
+
+resizeFrame :: Frame () -> TVar Api.BoardState -> Panel() -> IO ()
+resizeFrame f vBoardState p_board = do
+ (Size w h) <- windowGetClientSize f
+ Api.resize p_board vBoardState
+ let x = max w (h-66)
+ windowSetClientSize f $ Size x (x+66)
+ void $ windowLayout f
+
+
+updateBoardLayout :: Panel() -> Panel() -> Panel() -> Panel() -> TVar Api.BoardState -> IO ()
+updateBoardLayout pback board white black vBoardState = do
+ state <- readTVarIO vBoardState
+ set pback [ layout := column 0 [ hfill $ widget (if Api.perspective state == White then black else white)
+ , stretch $ minsize (Size 320 320) $ shaped $ widget board
+ , hfill $ widget (if Api.perspective state == White then white else black)]]
+
+
+wxPieceSetsMenu :: Menu () -> TVar Api.BoardState -> Panel () -> IO ()
+wxPieceSetsMenu ctxMenu vState p = do
+ sub <- menuPane [text := "Piece Sets"]
+ mapM_ (\ps -> menuItem sub [ text := display ps, on command := Api.setPieceSet vState ps >> repaint p ]) pieceSets
+ void $ menuSub ctxMenu sub [ text := "Piece Sets" ]
+
+
+onKeyDownHandler :: Handle -> Panel () -> Frame () -> TVar Api.BoardState -> StatusField -> EventKey -> IO ()
+onKeyDownHandler h p_board f vBoardState sf evt
+ | onlyKey evt 'X' = do Api.cancelLastPreMove vBoardState; repaint p_board
+
+ | onlyKey evt 'Q' = do Api.pickUpPieceFromHolding vBoardState Queen; repaint p_board
+ | onlyKey evt 'B' = do Api.pickUpPieceFromHolding vBoardState Bishop; repaint p_board
+ | onlyKey evt 'K' = do Api.pickUpPieceFromHolding vBoardState Knight; repaint p_board
+ | onlyKey evt 'R' = do Api.pickUpPieceFromHolding vBoardState Rook; repaint p_board
+ | onlyKey evt 'P' = do Api.pickUpPieceFromHolding vBoardState Pawn; repaint p_board
+ | (keyKey evt == KeyEscape) && isNoneDown (keyModifiers evt) = do Api.discardDraggedPiece vBoardState; repaint p_board
+
+ | onlyKey evt 'N' = hPutStrLn h "5 decline"
+ | onlyKey evt 'Y' = hPutStrLn h "5 accept"
+
+ | keyWithMod evt 'W' justControl = close f
+ | keyWithMod evt 'O' justControl = Api.togglePromotion vBoardState >>= \p -> set sf [text := "=" ++ show p]
+ | otherwise = return ()
+ where onlyKey evt c = (keyKey evt == KeyChar c) && isNoneDown (keyModifiers evt)
+ keyWithMod evt c mod = (keyKey evt == KeyChar c) && (keyModifiers evt == mod)
+
+
+onKeyUpHandler :: TVar Api.BoardState -> Handle -> StatusField -> EventKey -> IO ()
+onKeyUpHandler vBoardState h sf evt
+ | (keyKey evt == KeyControl) && isNoneDown (keyModifiers evt) =
+ Api.promotion `fmap` readTVarIO vBoardState >>= \p -> do
+ hPutStrLn h $ "5 promote " ++ show p
+ set sf [text := "=" ]
+ | otherwise = return ()
+
diff --git a/src/Macbeth/Wx/GameMoves.hs b/src/Macbeth/Wx/GameMoves.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/GameMoves.hs
@@ -0,0 +1,83 @@
+module Macbeth.Wx.GameMoves (
+ wxGameMoves
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Move
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Maybe
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+
+data MoveShort = MoveShort {num :: Int, turnColor :: PColor, move :: String}
+
+moveShort :: Move -> MoveShort
+moveShort m = MoveShort (moveNumber m) (turn m) (fromJust $ movePretty m)
+
+wxGameMoves :: SplitterWindow () -> TVar [Move] -> IO (ScrolledWindow (), IO ())
+wxGameMoves f t = do
+ sw <- scrolledWindow f [ scrollRate := sz 5 5]
+ p <- panel sw []
+ txtCtrls <- replicateM 250 (staticTextSmall p "")
+ let update = do
+ moves <- readTVarIO t
+ let mx = reverse $ moveShort <$> filter (isJust . movePretty) moves
+ let labels = layoutMoves mx
+ zipWithM_ (\tCtrl mv -> set tCtrl [text := mv, visible := True]) txtCtrls labels
+ sizerX <- sizerFromLayout sw (if null mx then empty
+ else container p $ margin 30 $ grid 5 0 (layoutSt $ take (length labels) txtCtrls))
+ windowSetSizer sw sizerX
+ windowFitInside sw
+
+ update
+ return (sw, update)
+
+layoutSt (t1:t2:t3:tx) = [ vspace 18
+ , widget t1
+ , widget t2
+ , widget t3] : layoutSt tx
+layoutSt _ = []
+
+
+layoutMoves :: [MoveShort] -> [String]
+layoutMoves [] = []
+layoutMoves [s1]
+ | turnColor s1 == White = [show (num s1 - 1) ++ ".", "...", move s1]
+ | otherwise = [show (num s1) ++ ".", move s1, ""]
+layoutMoves (s1:s2:sx)
+ | turnColor s1 == White = [show (num s1 - 1) ++ ".", "...", move s1] ++ layoutMoves (s2:sx)
+ | otherwise = [show (num s1) ++ ".", move s1, move s2] ++ layoutMoves sx
+
+
+
+staticTextSmall :: Panel () -> String -> IO (StaticText ())
+staticTextSmall p s = staticText p [ text := s
+ , fontFace := "Avenir Next Medium"
+ , fontSize := 14
+ , visible := False
+ , fontWeight := WeightNormal]
+
+{-
+
+-- selected <- readTVarIO vSel
+-- vSel <- newTVarIO 0
+-- set (txtCtrl $ mx' !! selected) [bgcolor := red]
+-- set p [on rightKey := doRightKey vSel mx' ]
+-- set p [on leftKey := doLeftKey vSel mx' ]
+
+doRightKey vSel mx = do
+ selected <- readTVarIO vSel
+ set (txtCtrl $ mx !! selected) [bgcolor := colorSystem ColorBackground]
+ selected <- atomically $ modifyTVar vSel (\x -> min (length mx - 1) (x + 1)) >> readTVar vSel
+ set (txtCtrl $ mx !! selected) [bgcolor := red]
+
+doLeftKey vSel mx = do
+ selected <- readTVarIO vSel
+ set (txtCtrl $ mx !! selected) [bgcolor := colorSystem ColorBackground]
+ selected <- atomically $ modifyTVar vSel (\x -> max 0 (x - 1)) >> readTVar vSel
+ set (txtCtrl $ mx !! selected) [bgcolor := red]
+-}
+
+
diff --git a/src/Macbeth/Wx/GameType.hs b/src/Macbeth/Wx/GameType.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/GameType.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Macbeth.Wx.GameType (
+ Category (..),
+ Board (..),
+ gameTypes,
+ gameTypeSelectionToString,
+ onSelectGameTypeCategory
+) where
+
+import Macbeth.Wx.Utils
+
+import Data.Char
+import Data.Map
+import Graphics.UI.WX
+
+data Category = Chess | Suicide | Losers | Atomic | Wild | Crazyhouse | Bughouse deriving (Eq, Ord, Show, Read)
+
+data Board = Board {_id :: String, display :: String} deriving (Show, Read)
+
+gameTypes :: Map Category [Board]
+gameTypes = fromList [ (Chess, []), (Suicide, []), (Losers, []), (Atomic, []),
+ (Wild, [ Board "w1" "Reversed King and Queen"
+ , Board "w2" "Shuffle position"
+ , Board "w3" "Shuffle position, mirrored"
+ , Board "w4" "Random pieces, balanced bishops"
+ , Board "w5" "Pawns on 7th rank"
+ , Board "w8" "Pawns on 4th rank"
+ , Board "w8a" "Panwns on 5th rank"
+ , Board "wild fr" "Fisher Random"])
+ , (Crazyhouse, [])
+ , (Bughouse, [])]
+
+
+gameTypeSelectionToString :: Category -> Maybe Board -> String
+gameTypeSelectionToString _ (Just board) = _id board
+gameTypeSelectionToString cat _ = fmap toLower (show cat)
+
+
+onSelectGameTypeCategory :: Choice () -> Choice () -> IO ()
+onSelectGameTypeCategory c_boards c_category = do
+ category <- fmap read (getDisplaySelection c_category)
+ set c_boards [ items := fmap display $ gameTypes ! category]
+
diff --git a/src/Macbeth/Wx/GamesList.hs b/src/Macbeth/Wx/GamesList.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/GamesList.hs
@@ -0,0 +1,75 @@
+module Macbeth.Wx.GamesList (
+ wxGamesList
+) where
+
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.Utils
+
+import Graphics.UI.WX hiding (refresh)
+import Graphics.UI.WXCore
+import System.IO
+
+data GamesOpts = GamesOpts { refresh :: MenuItem ()
+ , showRated :: MenuItem ()
+ , showUnrated :: MenuItem ()
+ }
+
+wxGamesList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())
+wxGamesList glp h = do
+ gl <- listCtrl glp [ columns :=
+ [ ("#", AlignLeft, -1)
+ , ("Player 1", AlignLeft, -1)
+ , ("Rating", AlignLeft, -1)
+ , ("Player 2", AlignLeft, -1)
+ , ("Rating", AlignLeft, -1)
+ , ("Game type", AlignLeft, -1)
+ ]]
+ listCtrlSetColumnWidths gl 100
+
+ glCtxMenu <- menuPane []
+ gamesOpts <- getGamesOpts glCtxMenu
+ set (refresh gamesOpts) [on command := hPutStrLn h "4 games"]
+ return (gl, handler gamesOpts gl glCtxMenu h)
+
+
+handler :: GamesOpts -> ListCtrl () -> Menu () -> Handle -> FicsMessage -> IO ()
+handler gamesOpts gl glCtxMenu h cmd = case cmd of
+ Games games -> do
+ filterGamesList gl gamesOpts games
+ set (showRated gamesOpts) [on command := filterGamesList gl gamesOpts games]
+ set (showUnrated gamesOpts) [on command := filterGamesList gl gamesOpts games]
+ set gl [on listEvent := onGamesListEvent gl h]
+
+ listItemRightClickEvent gl (\evt -> do
+ pt <- listEventGetPoint evt
+ menuPopup glCtxMenu pt gl)
+ _ -> return ()
+
+
+onGamesListEvent :: ListCtrl() -> Handle -> EventList -> IO ()
+onGamesListEvent gl h evt = case evt of
+ ListItemActivated idx -> listCtrlGetItemText gl idx >>= hPutStrLn h . ("4 observe " ++)
+ _ -> return ()
+
+
+filterGamesList :: ListCtrl () -> GamesOpts -> [Game] -> IO ()
+filterGamesList gl opts games = do
+ showRated' <- get (showRated opts) checked
+ showUnrated' <- get (showUnrated opts) checked
+ set gl [items := [ toList g | g <- games
+ , (isRated (settings g) == showRated') ||
+ (isRated (settings g) == not showUnrated')
+ , not $ isPrivate $ settings g]]
+
+
+getGamesOpts :: Menu () -> IO GamesOpts
+getGamesOpts ctxMenu = GamesOpts
+ <$> menuItem ctxMenu [ text := "Refresh" ]
+ <*> menuItem ctxMenu [ text := "Show rated games", checkable := True, checked := True]
+ <*> menuItem ctxMenu [ text := "Show unrated games", checkable := True, checked := True]
+
+
+toList :: Game -> [String]
+toList g = [show $ Macbeth.Fics.Api.Game.id g, nameW g, show $ ratingW g, nameB g, show $ ratingB g, show $ gameType $ settings g]
+
diff --git a/src/Macbeth/Wx/Login.hs b/src/Macbeth/Wx/Login.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Login.hs
@@ -0,0 +1,66 @@
+module Macbeth.Wx.Login (
+ wxLogin
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.Utils
+
+import Control.Concurrent.Chan
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+import System.IO
+
+data WxLogin = WxLogin {
+ name :: TextCtrl ()
+ , password :: TextCtrl ()
+ , guestLogin :: CheckBox ()
+}
+
+
+wxLogin :: Handle -> Chan FicsMessage -> IO ()
+wxLogin h chan = do
+ f <- frameFixed [ text := "Macbeth" ]
+ p <- panel f []
+ wxInputs <- loginInputs p
+ set (guestLogin wxInputs) [on command := toggleLoginFields wxInputs]
+
+ b_ok <- button p [text := "Login", on command := okBtnHandler wxInputs f h chan]
+ b_can <- button p [text := "Quit", on command := close f]
+
+ set f [ defaultButton := b_ok
+ , layout := container p $ margin 10 $ column 25 [
+ boxed "Login @ freechess.org" (grid 15 15 [
+ [ label "Username:", hfill $ widget $ name wxInputs]
+ ,[ label "Password:", hfill $ widget $ password wxInputs]
+ ,[ label "Login as Guest:", hfill $ widget $ guestLogin wxInputs]])
+ , floatBottomRight $ row 5 [widget b_ok, widget b_can]]
+ ]
+ dupChan chan >>= registerWxCloseEventListener f
+
+
+okBtnHandler :: WxLogin -> Frame() -> Handle -> Chan FicsMessage -> IO ()
+okBtnHandler wxInputs f h chan = do
+ isGuestLogin <- get (guestLogin wxInputs) checked
+ username <- get (name wxInputs) text
+ hPutStrLn h (if isGuestLogin then "guest" else username) >> loop >> close f
+ where
+ loop = readChan chan >>= handlePw
+
+ handlePw :: FicsMessage -> IO ()
+ handlePw Password = get (password wxInputs) text >>= hPutStrLn h
+ handlePw (GuestLogin _) = hPutStrLn h ""
+ handlePw Login = return ()
+ handlePw _ = loop
+
+
+loginInputs :: Panel () -> IO WxLogin
+loginInputs p = WxLogin
+ <$> textEntry p [alignment := AlignRight]
+ <*> textCtrlEx p wxTE_PASSWORD [alignment := AlignRight]
+ <*> checkBox p []
+
+toggleLoginFields :: WxLogin -> IO ()
+toggleLoginFields wxLogin = do
+ isChecked <- get (guestLogin wxLogin) checked
+ set (name wxLogin) [enabled := not isChecked]
+ set (password wxLogin) [enabled := not isChecked]
diff --git a/src/Macbeth/Wx/Match.hs b/src/Macbeth/Wx/Match.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Match.hs
@@ -0,0 +1,76 @@
+module Macbeth.Wx.Match (
+ wxMatch
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.GameType
+import Macbeth.Wx.Utils
+
+import Control.Concurrent.Chan
+import Data.Map
+import Data.Char
+import Graphics.UI.WX hiding (color)
+import Safe
+import System.IO
+
+data WxMatch = WxMatch {
+ category :: Choice (),
+ board :: Choice (),
+ name :: TextCtrl (),
+ time :: TextCtrl (),
+ inc :: TextCtrl (),
+ rated :: CheckBox (),
+ color :: Choice ()
+}
+
+wxMatch :: Handle -> Bool -> Chan FicsMessage -> IO ()
+wxMatch h isGuest chan = do
+ f <- frameFixed [ text := "Create a match" ]
+ p <- panel f []
+ match <- matchInputs p isGuest
+ set (category match) [on select ::= onSelectGameTypeCategory (board match)]
+
+ b_ok <- button p [text := "Match", on command := toString match >>= hPutStrLn h >> close f ]
+ b_can <- button p [text := "Cancel", on command := close f]
+
+ set f [ defaultButton := b_ok
+ , layout := container p $ margin 10 $ column 10 [
+ boxed "Game Type" (grid 15 15 [
+ [label "Category: ", hfill $ widget $ category match]
+ , [label "Board:" , hfill $ widget $ board match ]])
+ , boxed "" (grid 15 15 [
+ [ label "Player name:", hfill $ widget $ name match]
+ ,[ label "Rated:", hfill $ widget $ rated match]
+ ,[ label "Time:", hfill $ widget $ time match]
+ ,[ label "Inc:", hfill $ widget $ inc match]
+ ,[ label "Color:", hfill $ widget $ color match]
+ ])
+ , floatBottomRight $ row 5 [widget b_can, widget b_ok]]
+ ]
+ registerWxCloseEventListener f chan
+
+
+matchInputs :: Panel () -> Bool -> IO WxMatch
+matchInputs p isGuest = WxMatch
+ <$> choice p [ items := fmap show (keys gameTypes)]
+ <*> choice p []
+ <*> textEntry p [ ]
+ <*> textEntry p [ text := "5" ]
+ <*> textEntry p [ text := "0" ]
+ <*> checkBox p [ enabled := not isGuest ]
+ <*> choice p [ tooltip := "color", sorted := False, items := ["Automatic", "White", "Black"]]
+
+
+-- 4 match GuestXYZZ rated 5 0 white
+toString:: WxMatch -> IO String
+toString m = (("4 match " ++) . unwords) `fmap` sequence [
+ get (name m) text
+ , convertIsRated `fmap` get (rated m) enabled
+ , get (time m) text
+ , get (inc m) text
+ , get (color m) selection >>= fmap convertColor . get (color m) . item
+ , gameTypeSelectionToString <$> read `fmap` getDisplaySelection (category m)
+ <*> readMay `fmap` getDisplaySelection (board m)]
+ where
+ convertIsRated r = if r then "rated" else "unrated"
+ convertColor x = if x == "Automatic" then "" else fmap toLower x
diff --git a/src/Macbeth/Wx/PartnerOffer.hs b/src/Macbeth/Wx/PartnerOffer.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/PartnerOffer.hs
@@ -0,0 +1,35 @@
+module Macbeth.Wx.PartnerOffer (
+ wxPartnerOffer
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Player
+import Macbeth.Wx.Utils
+
+import Control.Concurrent
+import Graphics.UI.WX
+import System.IO
+
+
+wxPartnerOffer :: Handle -> UserHandle -> Chan FicsMessage -> IO ()
+wxPartnerOffer h userHandle chan = do
+ f <- frame []
+ p <- panel f []
+
+ b_accept <- button p [text := "Accept", on command := hPutStrLn h ("5 partner" ++ name userHandle) >> close f]
+ b_decline <- button p [text := "Decline", on command := hPutStrLn h "5 decline" >> close f]
+ st_params <- staticText p [ text := name userHandle ++ " offers to be your bughouse partner."
+ , fontFace := "Avenir Next Medium"
+ , fontSize := 16
+ , fontWeight := WeightBold]
+
+ set f [ defaultButton := b_accept
+ , layout := container p $ margin 10 $
+ column 5 [boxed "Bughouse" (
+ grid 5 5 [
+ [ hfill $ widget st_params]]
+ )
+ , floatBottomRight $ row 5 [widget b_accept, widget b_decline]]
+ ]
+
+ dupChan chan >>= registerWxCloseEventListener f
diff --git a/src/Macbeth/Wx/Pending.hs b/src/Macbeth/Wx/Pending.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Pending.hs
@@ -0,0 +1,82 @@
+module Macbeth.Wx.Pending (
+ wxPending
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.PendingOffer
+import Macbeth.Wx.Utils
+
+import Control.Concurrent.STM
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+import System.IO
+
+
+data PendingActions =
+ PendingTo { accept :: MenuItem (), decline :: MenuItem ()}
+ | PendingFrom { withdraw :: MenuItem () }
+
+
+wxPending :: Handle -> Panel () -> IO (Panel (), FicsMessage -> IO ())
+wxPending h p' = do
+ p <- panel p' []
+ stFrom <- staticText p [ text := "Offers from other players:", fontSize := 12]
+ lcFrom <- listCtrl p [ columns := [ ("#", AlignLeft, -1), ("offer", AlignLeft, -1)]]
+ vPending <- newTVarIO ([] :: [PendingOffer])
+
+ stTo <- staticText p [ text := "Offers to other players:", fontSize := 12]
+ lcTo <- listCtrl p [columns := [ ("#", AlignLeft, -1), ("offer", AlignLeft, -1)]]
+
+ set p [ layout := column 5 [ hfill $ widget stFrom
+ , fill $ widget lcFrom
+ , hfill $ widget $ vspace 5
+ , hfill $ widget $ hrule 1
+ , hfill $ widget $ vspace 5
+ , hfill $ widget stTo
+ , fill $ widget lcTo]]
+
+ listItemRightClickEvent lcFrom (ctxMenuHandler h lcFrom From)
+ listItemRightClickEvent lcTo (ctxMenuHandler h lcTo To)
+
+ let handler cmd = case cmd of
+
+ Pending offer -> do
+ atomically $ modifyTVar vPending (++ [offer])
+ itemAppend (if isFrom offer then lcFrom else lcTo) (toList offer)
+
+ PendingRemoved idx -> do
+ items <- atomically $ do
+ modifyTVar vPending $ filter ((/= idx) . offerId)
+ readTVar vPending
+ itemsDelete lcFrom
+ itemsDelete lcTo
+ mapM_ (itemAppend lcTo) (fmap toList (filter isTo items))
+ mapM_ (itemAppend lcFrom) (fmap toList (filter isFrom items))
+ _ -> return ()
+
+ return (p, handler)
+
+
+toList :: PendingOffer -> [String]
+toList (PendingOffer _ id _ _ params) = [show id, params]
+
+
+ctxMenuHandler :: Handle -> ListCtrl () -> Origin -> Graphics.UI.WXCore.ListEvent () -> IO ()
+ctxMenuHandler h listCtrl origin evt = do
+ ctxMenu <- menuPane []
+ idx <- listEventGetIndex evt
+ offerId <- (head . (!! idx)) <$> get listCtrl items
+ _ <- (if origin == To then menuPendingTo else menuPendingFrom) ctxMenu h offerId
+ when (idx >= 0) $ listEventGetPoint evt >>= flip (menuPopup ctxMenu) listCtrl
+
+
+menuPendingFrom :: Menu () -> Handle -> String -> IO PendingActions
+menuPendingFrom ctxMenu h offerId = PendingTo
+ <$> menuItem ctxMenu [ text := "Accept", on command := hPutStrLn h ("4 accept " ++ offerId)]
+ <*> menuItem ctxMenu [ text := "Decline", on command := hPutStrLn h ("4 decline " ++ offerId)]
+
+
+menuPendingTo :: Menu () -> Handle -> String -> IO PendingActions
+menuPendingTo ctxMenu h offerId = PendingFrom
+ <$> menuItem ctxMenu [ text := "Withdraw", on command := hPutStrLn h ("4 withdraw " ++ offerId)]
+
diff --git a/src/Macbeth/Wx/PieceSet.hs b/src/Macbeth/Wx/PieceSet.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/PieceSet.hs
@@ -0,0 +1,29 @@
+module Macbeth.Wx.PieceSet (
+ PieceSet(..),
+ pieceSets,
+ pieceSetFindSize
+) where
+
+import Data.Maybe
+import Safe
+
+
+{-
+http://ixian.com/chess/jin-piece-sets/
+This work by Eric De Mund is licensed under a Creative Commons Attribution-Share Alike 3.0 Unported License
+-}
+
+data PieceSet = PieceSet { path :: FilePath, display :: String }
+
+pieceSets = [
+ PieceSet "alpha.ead-01" "Alpha (ead-01)"
+ , PieceSet "alpha.ead-02" "Alpha (ead-02)"
+ , PieceSet "merida.ead-01" "Merida (ead-01)"
+ , PieceSet "merida.ead-02" "Merida (ead-02)"
+ , PieceSet "uscf.ead-01" "USCF (ead-01)"
+ , PieceSet "uscf.ead-02" "USCF (ead-02)"]
+
+pieceSetFindSize :: Int -> Int
+pieceSetFindSize panelWidth =
+ fromMaybe 300 $ headMay $ dropWhile (< round (fromIntegral panelWidth / 8)) sizes
+ where sizes = [20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,52,56,60,64,72,80,88,96,112,128,144,300]
diff --git a/src/Macbeth/Wx/PlayersList.hs b/src/Macbeth/Wx/PlayersList.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/PlayersList.hs
@@ -0,0 +1,103 @@
+module Macbeth.Wx.PlayersList (
+ wxPlayersList
+) where
+
+import Macbeth.Fics.Api.Player
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.Utils
+
+import Paths
+
+import Data.List
+import Graphics.UI.WX hiding (when)
+import Graphics.UI.WXCore hiding (when)
+import System.IO
+
+
+data CtxMenu = CtxMenu {
+ match :: MenuItem ()
+ , finger :: MenuItem ()
+ , history :: MenuItem ()
+ , observe :: MenuItem ()
+ , partner :: MenuItem ()
+}
+
+wxPlayersList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())
+wxPlayersList slp h = do
+ sl <- listCtrl slp [columns := [
+ ("Handle", AlignLeft, -1)
+ , ("State", AlignRight, -1)
+ , ("Rating", AlignRight, -1)
+ , ("Title", AlignRight, -1)]]
+
+ listCtrlSetColumnWidths sl 120
+ images >>= flip (listCtrlAssignImageList sl) wxIMAGE_LIST_SMALL
+
+ ctxMenu <- menuPane []
+ ctxMenuPopup <- createCtxMenu ctxMenu
+ let updateM user (f, cmd) = set (f ctxMenuPopup) [on command := hPutStrLn h $ "6 " ++ cmd ++ " " ++ user]
+
+ listItemRightClickEvent sl (\evt -> do
+ player <- listEventGetIndex evt >>= get sl . item
+ sequence_ $ fmap (updateM (head player)) [(finger, "finger"), (partner, "partner"),
+ (match, "match"), (history, "history"), (observe, "observe")]
+ listEventGetPoint evt >>= flip (menuPopup ctxMenu) sl)
+
+ return (sl, handler sl)
+
+
+handler :: ListCtrl () -> FicsMessage -> IO ()
+handler sl cmd = case cmd of
+ Players players -> do
+ listCtrlDeleteAllItems sl
+ sequence_ $ fmap (addPlayer sl) players
+ _ -> return ()
+
+
+images :: IO (ImageList ())
+images = do
+ let imageFiles = map (\name -> "icons/" ++ name ++ ".gif") ["fa-user", "fa-desktop"]
+ imagePaths <- mapM getDataFileName imageFiles
+ imageListFromFiles (sz 16 16) imagePaths
+
+
+addPlayer :: ListCtrl () -> Player -> IO ()
+addPlayer l player = do
+ count <- listCtrlGetItemCount l
+
+ item <- listItemCreate
+ listItemSetId item count
+ --when (Computer `elem` titles seek) $ listItemSetBackgroundColour item (colorRGB 125 149 184)
+ listItemSetImage item (fmap imageIdx handleType $ handle player)
+
+ listCtrlInsertItem l item
+ mapM_ (\(column,txt) -> listCtrlSetItem l count column txt (-1)) (zip [0..] (toList player))
+
+ where
+ imageIdx :: [HandleType] -> Int
+ imageIdx types = if Computer `elem` types then 1 else 0
+
+
+createCtxMenu :: Menu () -> IO CtxMenu
+createCtxMenu ctxMenu = CtxMenu
+ <$> menuItem ctxMenu [ text := "Match"]
+ <*> menuItem ctxMenu [ text := "Finger"]
+ <*> menuItem ctxMenu [ text := "History"]
+ <*> menuItem ctxMenu [ text := "Observe"]
+ <*> menuItem ctxMenu [ text := "Partner"]
+
+toList :: Player -> [String]
+toList (Player rating status (UserHandle username ht)) =
+ [username, toStringStatus status, show rating, showHandleType ht]
+ where
+ toStringStatus InvolvedInAGame = "Playing"
+ toStringStatus RunningASimulMatch = "Playing Simul"
+ toStringStatus NotOpenForMatch = "Not Open"
+ toStringStatus ExaminingAGame = "Examining"
+ toStringStatus InactiveOrBusy = "Inactive"
+ toStringStatus NotBusy = "Not Busy"
+ toStringStatus InvolvedInATournament = "Tournament"
+
+ showHandleType = intercalate ", " . fmap show .
+ filter (not . flip elem [Unregistered, Computer, NOT_DOCUMENTED, ServiceRepresentative])
+
diff --git a/src/Macbeth/Wx/Seek.hs b/src/Macbeth/Wx/Seek.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Seek.hs
@@ -0,0 +1,118 @@
+module Macbeth.Wx.Seek (
+ wxSeek
+ , toString
+ , SeekInfo (..)
+) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.GameType
+import Macbeth.Wx.Utils
+
+import Control.Concurrent.Chan
+import Data.Map (keys)
+import Graphics.UI.WX hiding (color)
+import Safe
+import System.IO
+
+-- seek [time inc] [rated|unrated] [white|black] [crazyhouse] [suicide] [wild #] [auto|manual] [formula] [rating-range]
+data WxSeek = WxSeek {
+ category :: Choice ()
+ , board :: Choice ()
+ , time :: TextCtrl ()
+ , inc :: TextCtrl ()
+ , rated :: CheckBox ()
+ , color :: Choice ()
+ , manual :: CheckBox ()
+--, formula :: CheckBox ()
+ , ratingFrom :: TextCtrl ()
+ , ratingTo :: TextCtrl ()
+}
+
+data SeekInfo = SeekInfo {
+ _category :: Category
+ , _board :: Maybe Board
+ , _time :: Int
+ , _inc :: Int
+ , _rated :: Bool
+ , _color :: Maybe PColor
+ , _manual :: Bool
+-- , _formula :: Bool
+ , _ratingFrom :: Int
+ , _ratingTo :: Int
+}
+
+
+wxSeek :: Handle -> Bool -> Chan FicsMessage -> IO ()
+wxSeek h isGuest chan = do
+ f <- frameFixed [ text := "Seek a match" ]
+ p <- panel f []
+ match <- matchInputs p isGuest
+ set (category match) [on select ::= onSelectGameTypeCategory (board match)]
+
+ b_ok <- button p [text := "Create", on command := readSeek match >>= hPutStrLn h . ("4 seek " ++) . toString >> close f ]
+ b_can <- button p [text := "Cancel", on command := close f]
+
+ set f [ defaultButton := b_ok
+ , layout := container p $ margin 10 $ column 15 [
+ boxed "Game Type" (grid 15 15 [
+ [label "Category: ", hfill $ widget $ category match, label "Board:", hfill $ widget $ board match ]
+ ]),
+ boxed "" (grid 15 15 [
+ [ label "Time [min.]:", hfill $ widget $ time match, label "Inc [sec.]:", hfill $ widget $ inc match]
+ , [ label "Rated:", hfill $ widget $ rated match, label "Color:", hfill $ widget $ color match]
+ , [ label "Manual accept:", hfill $ widget $ manual match, empty, empty]
+ , [ label "Rating from", hfill $ widget $ ratingFrom match, label "to", hfill $ widget $ ratingTo match]
+ ])
+ , floatBottomRight $ row 5 [widget b_can, widget b_ok]]
+ ]
+ registerWxCloseEventListener f chan
+
+
+-- seek [time inc] [rated|unrated] [white|black] [crazyhouse] [suicide]
+-- [wild #] [auto|manual] [formula] [rating-range]
+toString :: SeekInfo -> String
+toString m = unwords $ filter (/= "") [
+ show $ _time m
+ , show $ _inc m
+ , convertIsRated $ _rated m
+ , maybe "" convertColor (_color m)
+ , gameTypeSelectionToString (_category m) (_board m)
+ , convertAutoManual (_manual m)
+ , convertRatingRange (_ratingFrom m) (_ratingTo m)]
+ where
+ convertIsRated r = if r then "r" else "u"
+ convertColor White = "w"
+ convertColor Black = "b"
+ convertRatingRange from to = show from ++ "-" ++ show to
+ convertAutoManual isManual = if isManual then "m" else "a"
+
+
+readSeek :: WxSeek -> IO SeekInfo
+readSeek m = SeekInfo
+ <$> read `fmap` getDisplaySelection (category m)
+ <*> readMay `fmap` getDisplaySelection (board m)
+ <*> read `fmap` get (time m) text
+ <*> read `fmap` get (inc m) text
+ <*> get (rated m) checked
+ <*> convertColor `fmap` getDisplaySelection (color m)
+ <*> get (manual m) checked
+ <*> read `fmap` get (ratingFrom m) text
+ <*> read `fmap` get (ratingTo m) text
+ where
+ convertColor "Automatic" = Nothing
+ convertColor c = read c
+
+
+matchInputs :: Panel () -> Bool -> IO WxSeek
+matchInputs p isGuest = WxSeek
+ <$> choice p [items := fmap show (filter (/= Bughouse) $ keys gameTypes)]
+ <*> choice p []
+ <*> textEntry p [ text := "5"]
+ <*> textEntry p [ text := "0"]
+ <*> checkBox p [ enabled := not isGuest ]
+ <*> choice p [tooltip := "color", sorted := False, items := ["Automatic", "White", "Black"]]
+ <*> checkBox p []
+ <*> textEntry p [ text := "0"]
+ <*> textEntry p [ text := "9999"]
+
diff --git a/src/Macbeth/Wx/SoughtList.hs b/src/Macbeth/Wx/SoughtList.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/SoughtList.hs
@@ -0,0 +1,139 @@
+module Macbeth.Wx.SoughtList (
+ wxSoughtList
+) where
+
+import Macbeth.Fics.Api.Seek
+import Macbeth.Fics.Api.Game hiding (gameType, isRated)
+import Macbeth.Fics.FicsMessage
+import Macbeth.Wx.Utils
+import Paths
+
+import Control.Concurrent.STM
+import Control.Monad
+import Graphics.UI.WX hiding (when)
+import Graphics.UI.WXCore hiding (when)
+import System.IO
+import Data.List (elemIndex)
+
+data SoughtOpts = SoughtOpts { computerOffers :: MenuItem ()
+ , unregisteredPlayers :: MenuItem ()
+ , unratedOffers :: MenuItem ()
+ , ratedOffers :: MenuItem () }
+
+wxSoughtList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())
+wxSoughtList slp h = do
+ sl <- listCtrl slp [columns := [ ("#", AlignLeft, -1)
+ , ("Handle", AlignLeft, -1)
+ , ("Rating", AlignLeft, -1)
+ , ("Time (start inc.)", AlignRight, -1)
+ , ("Type", AlignRight, -1)]
+ ]
+
+ set sl [on listEvent := onSeekListEvent sl h]
+ listCtrlSetColumnWidths sl 100
+
+ ctxMenu <- menuPane []
+ soughtOpts <- getSoughtOpts ctxMenu
+ vSoughtList <- newTVarIO ([] :: [Seek])
+
+ set (computerOffers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]
+ set (unregisteredPlayers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]
+ set (unratedOffers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]
+ set (ratedOffers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]
+
+ listItemRightClickEvent sl (\evt -> do
+ pt <- listEventGetPoint evt
+ menuPopup ctxMenu pt sl)
+
+ imagePaths <- mapM getDataFileName imageFiles
+ images <- imageListFromFiles (sz 16 16) imagePaths
+
+ listCtrlAssignImageList sl images wxIMAGE_LIST_SMALL
+
+ let handler cmd = case cmd of
+ NewSeek seek -> do
+ atomically $ modifyTVar vSoughtList (\sl -> sl ++ [seek])
+ showSeek' <- showSeek soughtOpts
+ when (showSeek' seek) $ addSeek sl seek
+
+ ClearSeek -> itemsDelete sl
+
+ RemoveSeeks gameIds -> do
+ seeks <- get sl items
+ sequence_ $ fmap (deleteSeek sl . findSeekIdx seeks) gameIds
+
+ _ -> return ()
+
+ return (sl, handler)
+
+imageNames = ["fa-user", "fa-desktop"]
+
+
+imageFiles = map (\name -> "icons/" ++ name ++ ".gif") imageNames
+
+
+addSeek :: ListCtrl () -> Seek -> IO ()
+addSeek l seek = do
+ count <- listCtrlGetItemCount l
+
+ item <- listItemCreate
+ listItemSetId item count
+ --when (Computer `elem` titles seek) $ listItemSetBackgroundColour item (colorRGB 125 149 184)
+ listItemSetImage item $ if Computer `elem` titles seek then 1 else 0
+
+ listCtrlInsertItem l item
+ mapM_ (\(column,txt) -> listCtrlSetItem l count column txt (-1)) (zip [0..] (toList seek))
+
+
+showSeek :: SoughtOpts -> IO (Seek -> Bool)
+showSeek opts = do
+ computerOffers' <- get (computerOffers opts) checked
+ unregisteredPlayers' <- get (unregisteredPlayers opts) checked
+ unratedOffers' <- get (unratedOffers opts) checked
+ ratedOffers' <- get (ratedOffers opts) checked
+ return $ \s -> (gameType s `elem` [Untimed, Standard, Blitz, Lightning]) &&
+ ((Computer `elem` titles s) .>. computerOffers') &&
+ ((Unregistered `elem` titles s) .>. unregisteredPlayers') &&
+ (isRated s .>. ratedOffers') &&
+ (not (isRated s) .>. unratedOffers')
+
+
+(.>.) :: Bool -> Bool -> Bool
+(.>.) p q = (not p) || q
+
+
+filterSoughtList :: ListCtrl () -> SoughtOpts -> TVar [Seek] -> IO ()
+filterSoughtList sl opts vSoughtList = do
+ showSeek' <- showSeek opts
+ soughts <- readTVarIO vSoughtList
+ listCtrlDeleteAllItems sl
+ mapM_ (\s -> when (showSeek' s) $ addSeek sl s) soughts
+
+
+onSeekListEvent :: ListCtrl() -> Handle -> EventList -> IO ()
+onSeekListEvent sl h evt = case evt of
+ ListItemActivated idx -> listCtrlGetItemText sl idx >>= hPutStrLn h . ("4 play " ++)
+ _ -> return ()
+
+
+findSeekIdx :: [[String]] -> Int -> Maybe Int
+findSeekIdx seeks gameId = elemIndex gameId $ fmap (read . (!! 0)) seeks
+
+
+deleteSeek :: ListCtrl () -> Maybe Int -> IO ()
+deleteSeek sl (Just id) = itemDelete sl id
+deleteSeek _ _ = return ()
+
+
+getSoughtOpts :: Menu () -> IO SoughtOpts
+getSoughtOpts ctxMenu = SoughtOpts
+ <$> menuItem ctxMenu [ text := "Show computer offers", checkable := True, checked := True]
+ <*> menuItem ctxMenu [ text := "Show unregistered players", checkable := True, checked := True]
+ <*> menuItem ctxMenu [ text := "Show unrated offers", checkable := True, checked := True]
+ <*> menuItem ctxMenu [ text := "Show rated offers", checkable := True, checked := True]
+
+toList :: Seek -> [String]
+toList (Seek id name _ rating time inc isRated gameType _ _) =
+ [show id, name, show rating, show time ++ " " ++ show inc, show gameType ++ " " ++ showIsRated isRated]
+ where showIsRated True = "rated"
+ showIsRated False = "unrated"
diff --git a/src/Macbeth/Wx/StatusPanel.hs b/src/Macbeth/Wx/StatusPanel.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/StatusPanel.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Macbeth.Wx.StatusPanel (
+ createStatusPanel
+) where
+
+import Macbeth.Fics.FicsMessage hiding (gameId, Observing)
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Move
+import Macbeth.Utils.Utils
+import Macbeth.Utils.BoardUtils
+import Macbeth.Wx.BoardState
+import Macbeth.Wx.PieceSet
+import Macbeth.Wx.Utils
+
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import Data.List
+import Graphics.UI.WX hiding (when)
+
+
+createStatusPanel :: Panel () -> PColor -> TVar BoardState -> IO (Panel (), FicsMessage -> IO ())
+createStatusPanel p color vBoardState = do
+ move <- lastMove `fmap` readTVarIO vBoardState
+
+ p_status <- panel p []
+ t <- newTVarIO $ remainingTime color move
+ st <- staticTextFormatted p_status (formatTime $ remainingTime color move)
+ tx <- timer p_status [ interval := 1000
+ , on command := updateTime t st
+ , enabled := isActive move color]
+
+ p_color <- panel p_status [bgcolor := toWxColor color]
+ st_playerName <- staticTextFormatted p_status (namePlayer color move)
+ p_pieceHoldings <- panel p_status [on paint := paintPieceHolding color vBoardState]
+
+ set p_status [ layout := row 10 [ valignCenter $ minsize (Size 18 18) $ widget p_color
+ , widget st
+ , widget st_playerName
+ , marginWidth 5 $ marginTop $ fill $ widget p_pieceHoldings] ]
+
+ let handler = \case
+
+ GameMove _ move' -> when (gameId move' == gameId move) $ do
+ let time' = remainingTime color move'
+ atomically $ swapTVar t time'
+ set st [text := formatTime time']
+ set tx [enabled := isActive move' color]
+
+ GameResult id _ _ -> when (id == gameId move) $ set tx [enabled := False]
+
+ PieceHolding id phW' phB' -> when (id == gameId move) $ do
+ atomically $ modifyTVar vBoardState (\s -> s{ phW = phW', phB = phB' })
+ repaint p_status
+
+ _ -> return ()
+
+ return (p_status, handler)
+
+
+paintPieceHolding :: PColor -> TVar BoardState -> DC a -> t -> IO ()
+paintPieceHolding color state dc _ = do
+ px <- getPieceHolding color `fmap` readTVarIO state
+ zipWithM_ (drawPiece dc color) [A .. H] (frequency px)
+ where
+ frequency :: Ord a => [a] -> [(a, Int)]
+ frequency = map (head &&& length) . group . sort
+
+drawPiece :: DC a -> PColor -> Column -> (PType, Int) -> IO ()
+drawPiece dc color col (ptype, freq) = do
+ drawBitmap dc (pieceToBitmap pieceSize (head pieceSets) (Piece ptype color))
+ (toPos' fieldSize (Square col Eight) White) True []
+ set dc [pen := penColored black 2]
+ drawText dc (show freq) (Point (22 + fromEnum col * fieldSize) 15)
+ [ fontFace := "Avenir Next Medium"
+ , fontSize := 10
+ , fontWeight := WeightBold]
+ where fieldSize = 35
+ pieceSize = 24
+
+
+updateTime :: TVar Int -> StaticText () -> IO ()
+updateTime vTime st = do
+ time <- atomically $ modifyTVar vTime (\t -> t - 1) >> readTVar vTime
+ set st [text := formatTime time]
+
+
+isActive :: Move -> PColor -> Bool
+isActive move' color =
+ (moveNumber move' /= 1) &&
+ (turn move' == color) &&
+ (relation move' `elem` [OponentsMove, MyMove, Observing])
diff --git a/src/Macbeth/Wx/ToolBox.hs b/src/Macbeth/Wx/ToolBox.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/ToolBox.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Macbeth.Wx.ToolBox (
+ wxToolBox
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Player
+import Macbeth.Wx.Configuration
+import Macbeth.Wx.Finger
+import Macbeth.Wx.GamesList
+import Macbeth.Wx.Login
+import Macbeth.Wx.Match
+import Macbeth.Wx.Seek
+import Macbeth.Wx.Utils
+import Macbeth.Wx.PlayersList
+import Macbeth.Wx.SoughtList
+import Macbeth.Wx.Game
+import Macbeth.Wx.Challenge
+import Macbeth.Wx.PartnerOffer
+import Macbeth.Wx.Pending
+import Paths
+
+import Control.Concurrent
+import Control.Concurrent.Chan ()
+import Control.Monad
+import Foreign.Marshal.Alloc
+import Foreign.Storable
+import Foreign.Ptr
+import Foreign.C.Types
+import Graphics.UI.WX hiding (when)
+import Graphics.UI.WXCore hiding (when)
+import System.FilePath
+import System.IO
+import System.IO.Unsafe
+
+eventId = wxID_HIGHEST + 1
+
+wxToolBox :: Handle -> Chan FicsMessage -> IO ()
+wxToolBox h chan = do
+ f <- frame [ text := "Macbeth"]
+
+ tbar <- toolBarEx f False False []
+ tbarItem_seek <- toolItem tbar "Seek" False (unsafePerformIO $ getDataFileName $ "icons" "bullhorn.gif")
+ [ on command := dupChan chan >>= wxSeek h False, enabled := False, tooltip := "Seek" ]
+
+ tbarItem_match <- toolItem tbar "Match" False (unsafePerformIO $ getDataFileName $ "icons" "dot-circle-o.gif")
+ [ on command := dupChan chan >>= wxMatch h False, enabled := False, tooltip := "Match" ]
+
+ tbarItem_finger <- toolItem tbar "Finger" False (unsafePerformIO $ getDataFileName $ "icons" "fa-question.gif")
+ [ on command := hPutStrLn h "4 finger", enabled := False, tooltip := "Finger"]
+
+ status <- statusField []
+ statusLag <- statusField [ statusWidth := 100 ]
+ _ <- timer f [ interval := 2 * 60 * 1000, on command := hPutStrLn h "4 ping"]
+ statusLoggedIn <- statusField [ statusWidth := 100]
+
+
+ nb <- notebook f []
+
+ -- Sought list
+ slp <- panel nb []
+ (sl, soughtListHandler) <- wxSoughtList slp h
+
+ -- Games list
+ glp <- panel nb []
+ (gl, gamesListHandler) <- wxGamesList glp h
+
+ -- Pending
+ pending <- panel nb []
+ (pendingWidget, pendingHandler) <- wxPending h pending
+
+ -- Players
+ players <- panel nb []
+ (playersWidget, playersHandler) <- wxPlayersList players h
+
+ -- Console
+ cp <- panel nb []
+ ct <- textCtrlEx cp (wxTE_MULTILINE .+. wxTE_RICH .+. wxTE_READONLY) [font := fontFixed]
+ ce <- entry cp []
+ set ce [on enterKey := emitCommand ce h]
+
+
+ -- menu
+ m_file <- menuPane [text := "&File"]
+ menuItem m_file [text := "Settings", on command := dupChan chan >>= wxConfiguration ]
+
+ set f [ statusBar := [status, statusLoggedIn, statusLag],
+ layout := tabs nb
+ [ tab "Sought" $ container slp $ fill $ widget sl
+ , tab "Games" $ container glp $ fill $ widget gl
+ , tab "Pending" $ container pending $ fill $ widget pendingWidget
+ , tab "Players" $ container players $ fill $ widget playersWidget
+ , tab "Console" $ container cp ( column 5 [ fill $ widget ct
+ , hfill $ widget ce])
+ ]
+ , menuBar := [m_file]
+ , outerSize := sz 600 600
+ ]
+
+ -- preselect first tab
+ notebookSetSelection nb 0
+
+ vCmd <- newEmptyMVar
+ threadId <- forkIO $ eventLoop eventId chan vCmd f
+ windowOnDestroy f $ writeChan chan WxClose >> killThread threadId
+
+ evtHandlerOnMenuCommand f eventId $ takeMVar vCmd >>= \cmd ->
+ gamesListHandler cmd >>
+ soughtListHandler cmd >>
+ pendingHandler cmd >>
+ playersHandler cmd >>
+ case cmd of
+
+ NoSuchGame -> do
+ set status [text := "No such game. Updating games..."]
+ hPutStrLn h "4 games"
+
+ UserNotLoggedIn username -> do
+ set status [text := username ++ " is not logged in."]
+ hPutStrLn h "4 who"
+
+ PartnerNotOpen userHandle -> set status [text := name userHandle ++ " is not open for bughouse."]
+
+ PartnerOffer userHandle -> dupChan chan >>= wxPartnerOffer h userHandle
+
+ PartnerAccepted userHandle -> set status [text := name userHandle ++ " agrees to be your partner."]
+
+ PartnerDeclined userHandle -> set status [text := name userHandle ++ " declines the partnership request."]
+
+ SeekNotAvailable -> set status [text := "That seek is not available."]
+
+ InvalidPassword -> void $ set status [text := "Invalid password."]
+
+ LoginTimeout -> set status [ text := "Login Timeout." ]
+
+ Login -> dupChan chan >>= wxLogin h
+
+ LoggedIn handle -> do
+ set nb [on click := (onMouse nb >=> clickHandler h nb)]
+ hPutStrLn h `mapM_` [ "ping", "set seek 0", "set style 12", "iset pendinfo 1", "iset seekinfo 1", "iset nowrap 1", "iset defprompt 1", "iset block 1", "2 iset lock 1"]
+ set statusLoggedIn [ text := name handle]
+ mapM_ (`set` [ enabled := True ]) [tbarItem_seek, tbarItem_match, tbarItem_finger]
+
+ GuestLogin _ -> do
+ set tbarItem_seek [on command := dupChan chan >>= wxSeek h True ]
+ set tbarItem_match [on command := dupChan chan >>= wxMatch h True ]
+
+ msg@(Finger {}) -> dupChan chan >>= wxInfo msg
+
+ msg@(History {}) -> dupChan chan >>= wxInfo msg
+
+ WxObserve move chan' -> wxGame h move chan'
+
+ MatchRequested c -> dupChan chan >>= wxChallenge h c
+
+ WxMatchAccepted move chan' -> wxGame h move chan'
+
+ MatchDeclined user -> set status [text := user ++ " declines the match offer."]
+
+ MatchUserNotLoggedIn user -> set status [text := user ++ " not logged in."]
+
+ Ping _ avg _ -> set statusLag [ text := "Lag: " ++ show avg ++ "ms"]
+
+ TextMessage text -> appendText ct text
+
+ _ -> return ()
+
+
+emitCommand :: TextCtrl () -> Handle -> IO ()
+emitCommand textCtrl h = get textCtrl text >>= hPutStrLn h . ("5 " ++) >> set textCtrl [text := ""]
+
+
+onMouse :: Notebook() -> Point -> IO Int
+onMouse nb p = propagateEvent >> notebookHitTest nb p flag
+
+clickHandler :: Handle -> Notebook () -> Int -> IO ()
+clickHandler h nb idx = notebookGetPageText nb idx >>= \case
+ "Games" -> hPutStrLn h "5 games"
+ "Players" -> hPutStrLn h "5 who"
+ _ -> return ()
+
+
+{-# NOINLINE flag #-}
+flag :: Ptr CInt
+flag = unsafePerformIO flag'
+ where flag' = do
+ work <- malloc::IO (Ptr CInt)
+ poke work (fromIntegral wxBK_HITTEST_ONPAGE)
+ return work
diff --git a/src/Macbeth/Wx/Utils.hs b/src/Macbeth/Wx/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Macbeth/Wx/Utils.hs
@@ -0,0 +1,68 @@
+module Macbeth.Wx.Utils (
+ eventLoop,
+ registerWxCloseEventListener,
+ registerWxCloseEventListenerWithThreadId,
+ listItemRightClickEvent,
+ toWxColor,
+ getDisplaySelection,
+ staticTextFormatted
+) where
+
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Api
+
+import Control.Concurrent
+import Graphics.UI.WX
+import Graphics.UI.WXCore hiding (Column, Row)
+
+
+eventLoop :: Int -> Chan FicsMessage -> MVar FicsMessage -> Frame () -> IO ()
+eventLoop id chan vCmd f = readChan chan >>= putMVar vCmd >>
+ commandEventCreate wxEVT_COMMAND_MENU_SELECTED id >>= evtHandlerAddPendingEvent f >>
+ eventLoop id chan vCmd f
+
+registerWxCloseEventListener :: Frame () -> Chan FicsMessage -> IO ()
+registerWxCloseEventListener f chan = do
+ vCmd <- newEmptyMVar
+ threadId <- forkIO $ eventLoop (wxID_HIGHEST + 13) chan vCmd f
+ windowOnDestroy f $ killThread threadId
+
+ evtHandlerOnMenuCommand f (wxID_HIGHEST + 13) $ takeMVar vCmd >>= \cmd -> case cmd of
+ WxClose -> close f
+ _ -> return ()
+
+registerWxCloseEventListenerWithThreadId :: Frame () -> Chan FicsMessage -> IO ThreadId
+registerWxCloseEventListenerWithThreadId f chan = do
+ vCmd <- newEmptyMVar
+ threadId <- forkIO $ eventLoop (wxID_HIGHEST + 13) chan vCmd f
+
+ evtHandlerOnMenuCommand f (wxID_HIGHEST + 13) $ takeMVar vCmd >>= \cmd -> case cmd of
+ WxClose -> close f
+ _ -> return ()
+
+ return threadId
+
+
+listItemRightClickEvent :: ListCtrl a -> (Graphics.UI.WXCore.ListEvent () -> IO ()) -> IO ()
+listItemRightClickEvent listCtrl eventHandler
+ = windowOnEvent listCtrl [wxEVT_COMMAND_LIST_ITEM_RIGHT_CLICK] eventHandler listHandler
+ where
+ listHandler :: Graphics.UI.WXCore.Event () -> IO ()
+ listHandler evt = eventHandler $ objectCast evt
+
+
+getDisplaySelection :: Choice () -> IO String
+getDisplaySelection c = get c selection >>= get c . item
+
+
+toWxColor :: PColor -> Color
+toWxColor White = Graphics.UI.WXCore.white
+toWxColor Black = Graphics.UI.WXCore.black
+
+
+staticTextFormatted :: Panel () -> String -> IO (StaticText ())
+staticTextFormatted p s = staticText p [ text := s
+ , fontFace := "Avenir Next Medium"
+ , fontSize := 20
+ , fontWeight := WeightBold]
+
diff --git a/src/Paths.hs b/src/Paths.hs
new file mode 100644
--- /dev/null
+++ b/src/Paths.hs
@@ -0,0 +1,13 @@
+module Paths (
+ getDataFileName
+) where
+
+import Data.List
+import qualified Paths_Macbeth as PM
+import System.Environment.FindBin
+import System.FilePath
+
+getDataFileName :: FilePath -> IO FilePath
+getDataFileName f
+ | "app" `isInfixOf` __Bin__ = (( "Resources" f) . joinPath . init . splitPath) <$> getProgPath
+ | otherwise = PM.getDataFileName f
diff --git a/src/Paths_Macbeth.hs b/src/Paths_Macbeth.hs
new file mode 100644
--- /dev/null
+++ b/src/Paths_Macbeth.hs
@@ -0,0 +1,8 @@
+module Paths_Macbeth (
+ getDataFileName
+) where
+
+import System.FilePath
+
+getDataFileName :: FilePath -> IO FilePath
+getDataFileName f = return $ "resources" f
diff --git a/test/FicsMessageParserSpec.hs b/test/FicsMessageParserSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/FicsMessageParserSpec.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module FicsMessageParserSpec (spec) where
+
+import Test.Hspec
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Fics.Api.Challenge
+import qualified Macbeth.Fics.Api.Rating as R
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Game
+import Macbeth.Fics.Api.Seek
+import Macbeth.Fics.Api.Move
+import Macbeth.Fics.Api.PendingOffer
+import qualified Macbeth.Fics.Api.Player as P
+import Macbeth.Fics.Parsers.FicsMessageParser
+import Macbeth.Fics.Parsers.MoveParser hiding (move)
+import Macbeth.Fics.Parsers.PositionParser
+
+import Data.Attoparsec.ByteString.Char8 hiding (Fail, Result, D)
+import qualified Data.ByteString.Char8 as BS
+
+data Result = Pass | Fail String deriving (Eq)
+
+spec :: Spec
+spec =
+ describe "Parser test" $ do
+
+ it "user not logged in after observe" $ parseFicsMessage "\NAK6\SYN80\SYNDharmadhikari is not logged in.\n\ETB\n"
+ `shouldBe` (Right $ UserNotLoggedIn "Dharmadhikari")
+
+ it "command message parser" $ commandMessageParserTest `shouldBe` True
+
+ it "seek msg parser" $ seekMsgParserTest `shouldBe` True
+
+ it "move parser" $ moveParserTest `shouldBe` True
+
+ it "position parser" $ positionTest `shouldBe` True
+
+ it "ping" $ parseFicsMessage ":min/avg/max/mdev = 131.497/132.073/132.718/0.460 ms\n"
+ `shouldBe` Right (Ping 131 132 133)
+
+ it "pending from" $ parseFicsMessage " 28 w=Schoon t=match p=Schoon ( 999) GuestNXQS (----) unrated blitz 5 0\n"
+ `shouldBe ` Right (Pending $ PendingOffer From 28 (P.UserHandle "Schoon" []) "match" "Schoon ( 999) GuestNXQS (----) unrated blitz 5 0")
+
+ it "pendingTo" $ parseFicsMessage "\NAK4\SYN73\SYNIssuing: GuestFTYL (----) GuestCVXP (----) unrated blitz 5 0.\n\n 3 w=GuestCVXP t=match p=GuestFTYL (----) GuestCVXP (----) unrated blitz 5 0\n\ETB\n"
+ `shouldBe` Right (Pending $ PendingOffer To 3 (P.UserHandle "GuestCVXP" []) "match" "GuestFTYL (----) GuestCVXP (----) unrated blitz 5 0")
+
+ it "pending removed" $ parseFicsMessage " 28\n"
+ `shouldBe` Right (PendingRemoved 28)
+
+ it "pending removed, after withdraw" $ parseFicsMessage "\NAK4\SYN147\SYNYou withdraw the match offer to GuestFZHQ.\n\n 1\n\ETB\n"
+ `shouldBe` Right (PendingRemoved 1)
+
+
+commandMessageParserTest :: Bool
+commandMessageParserTest = all (== Pass) $ fmap compareCmdMsg commandMessageParserTestData
+
+commandMessageParserTestData :: [(FicsMessage, String)]
+commandMessageParserTestData = [
+ (DrawRequest, "GuestDWXY offers you a draw.")
+ , (NoSuchGame, "\NAK5\SYN80\SYNThere is no such game.\n\ETB")
+ , (MatchRequested $ Challenge "GuestYWYK" R.Unrated "GuestMGSD" R.Unrated "unrated blitz 2 12", "Challenge: GuestYWYK (----) GuestMGSD (----) unrated blitz 2 12.")
+ , (GuestLogin "FOOBAR", "Press return to enter the server as \"FOOBAR\":")
+ , (GameCreation 484, "{Game 484 (GuestYLCL vs. GuestBYPB) Creating unrated blitz match.}\n")
+ , (AbortRequest "GuestSPLL", "GuestSPLL would like to abort the game; type \"abort\" to accept.")
+ , (TakebackRequest "GuestTYLF" 2, "GuestTYLF would like to take back 2 half move(s).")
+ , (GameResult 82 "Game aborted by mutual agreement" Aborted, "\NAK5\SYN11\SYNYou accept the abort request from GuestSPLL.\n\n{Game 82 (GuestTKHJ vs. GuestSPLL) Game aborted by mutual agreement} *\n\ETB")
+ , (GameResult 112 "Game aborted on move 1" Aborted, "\NAK4\SYN10\SYNThe game has been aborted on move one.\n\n{Game 112 (GuestSPLL vs. GuestTKHJ) Game aborted on move 1} *\n\ETB")
+ , (GameResult 383 "Game aborted by mutual agreement" Aborted, "\NAK5\SYN10\SYN\n{Game 383 (GuestRVNY vs. GuestZTNM) Game aborted by mutual agreement} *\n\ETB")
+ , (GameResult 112 "Game aborted on move 1" Aborted, "{Game 112 (GuestSPLL vs. GuestTKHJ) Game aborted on move 1} *")
+ , (GameResult 297 "Game aborted by mutual agreement" Aborted, "{Game 297 (GuestSPLL vs. GuestTKHJ) Game aborted by mutual agreement} *")
+ , (GameResult 10 "Kratt forfeits on time" WhiteWins, "{Game 10 (GidonC vs. Kratt) Kratt forfeits on time} 1-0\n")
+ , (GameResult 368 "CalicoCat resigns" WhiteWins, "{Game 368 (ALTOTAS vs. CalicoCat) CalicoCat resigns} 1-0")
+ , (GameResult 406 "GuestQLHT resigns" BlackWins, "\n{Game 406 (GuestQLHT vs. GuestVYVJ) GuestQLHT resigns} 0-1\n\nNo ratings adjustment done.")
+ , (GameResult 181 "Danimateit forfeits on time" BlackWins, "{Game 181 (Danimateit vs. WhatKnight) Danimateit forfeits on time} 0-1")
+ , (GameResult 196 "Game drawn by mutual agreement" Draw, "\NAK4\SYN34\SYN\n{Game 196 (GuestCWVD vs. GuestDWTL) Game drawn by mutual agreement} 1/2-1/2\n\nNo ratings adjustment done.\n\ETB")
+ , (GameResult 202 "Game drawn by mutual agreement" Draw, "\NAK5\SYN11\SYNYou accept the draw request from GuestNMNG.\n\n{Game 202 (GuestDKZD vs. GuestNMNG) Game drawn by mutual agreement} 1/2-1/2\n\nNo ratings adjustment done.\n\ETB")
+ , (MatchUserNotLoggedIn "GuestLHDG", "\NAK4\SYN73\SYNGuestLHDG is not logged in.\n\ETB")
+ , (PieceHolding 455 [Pawn,Rook,Knight] [Bishop,Queen], " game 455 white [PRN] black [BQ]")
+ , (PieceHolding 182 [Pawn,Pawn,Bishop] [Pawn,Queen,Queen], " game 182 white [PPB] black [PQQ] <- BQ\n")
+ , (SeekNotAvailable, "\NAK4\SYN158\SYNThat seek is not available.\n\ETB")
+
+ , (MatchRequested $ Challenge "Schoon" (R.Rating 997 R.None) "GuestPCFH" R.Unrated "unrated blitz 5 0", "Challenge: Schoon ( 997) GuestPCFH (----) unrated blitz 5 0.\n\r\aYou can \"accept\" or \"decline\", or propose different parameters.")
+ , (PromotionPiece Knight, "\NAK5\SYN92\SYNPromotion piece set to KNIGHT.\n\ETB\n")
+ , (PromotionPiece Queen, "\NAK5\SYN92\SYNPromotion piece set to QUEEN.\n\ETB\n")
+ , (PromotionPiece Bishop, "\NAK5\SYN92\SYNPromotion piece set to BISHOP.\n\ETB\n")
+ , (PromotionPiece Rook, "\NAK5\SYN92\SYNPromotion piece set to ROOK.\n\ETB\n")
+ , (PromotionPiece King, "\NAK5\SYN92\SYNPromotion piece set to KING.\n\ETB\n") -- Suicide
+ ]
+
+defaultMove = Move "-------- -------- -------- -------- -------- -------- -------- --------" [] White Nothing [WhiteShort,WhiteLong,BlackShort,BlackLong] 0 18 "nameWhite" "nameBlack" OponentsMove 3 0 39 39 180 180 1 Nothing "(0:00)" Nothing
+defaultMoveStr = "<12> -------- -------- -------- -------- -------- -------- -------- -------- W -1 1 1 1 1 0 18 nameWhite nameBlack -1 3 0 39 39 180 180 1 none (0:00) none 1 0 0\n"
+
+seekMsgParserTest :: Bool
+seekMsgParserTest = all (== Pass) $ fmap compareCmdMsg seekMsgParserTestData
+
+seekMsgParserTestData :: [(FicsMessage, String)]
+seekMsgParserTestData = [
+ (ClearSeek, "")
+ , (RemoveSeeks [59, 3, 11], " 59 3 11")
+ , (NewSeek $ Seek 7 "GuestNMZJ" [Unregistered] (R.Rating 0 R.Provisional) 15 5 False Standard (Just White) (0,9999), " 7 w=GuestNMZJ ti=01 rt=0P t=15 i=5 r=u tp=standard c=W rr=0-9999 a=t f=t")
+ , (NewSeek $ Seek 16 "CatNail" [Computer] (R.Rating 1997 R.None) 3 0 False Suicide Nothing (0,9999), " 16 w=CatNail ti=02 rt=1997 t=3 i=0 r=u tp=suicide c=? rr=0-9999 a=f f=f")
+ , (NewSeek $ Seek 56 "GuestCXDH" [Unregistered] (R.Rating 0 R.Provisional) 7 0 False Wild (Just White) (0,9999), " 56 w=GuestCXDH ti=01 rt=0P t=7 i=0 r=u tp=wild/4 c=W rr=0-9999 a=t f=f")
+ ]
+
+
+positionTest :: Bool
+positionTest = all (== Pass) $ fmap comparePosition positionTestData
+
+
+positionTestData :: [(Position, String)]
+positionTestData = [
+ ([], "-------- -------- -------- -------- -------- -------- -------- --------")
+ , ([ (Square A Eight, Piece Rook White)
+ , (Square B Seven, Piece Knight White)
+ , (Square C Six, Piece Bishop White)
+ , (Square D Five, Piece Queen White)
+ , (Square E Four, Piece King White)
+ , (Square F Three, Piece Pawn White)
+ , (Square G Two, Piece Rook Black)
+ , (Square H One, Piece King Black)], "R------- -N------ --B----- ---Q---- ----K--- -----P-- ------r- -------k")
+ ]
+
+moveParserTest :: Bool
+moveParserTest = all (== Pass) $ fmap withParser moveParserTestData
+
+moveParserTestData :: [(Parser (Maybe MoveDetailed), String, Maybe MoveDetailed)]
+moveParserTestData = [
+ (verboseMove', "P/c7-c5", Just $ Simple (Square C Seven) (Square C Five))
+ , (verboseMove', "P/f2-f1=R", Just $ Simple (Square F Two) (Square F One))
+ , (verboseMove', "o-o", Just CastleShort)
+ , (verboseMove', "o-o-o", Just CastleLong)
+ , (verboseMove', "B/@@-g6", Just $ Drop $ Square G Six)
+ ]
+
+{-
+parseGamesListTest :: Result
+parseGamesListTest = case parseFicsMessage $ BS.pack games of
+ Left txt -> Fail txt
+ Right (Games games) -> if length games == 584 then Pass else Fail $ show $ length games
+ where games = unsafePerformIO $ readFile "./test/Games.txt"
+-}
+
+withParser :: (Show a, Eq a) => (Parser a, String, a) -> Result
+withParser (parser, str, x) = case parseOnly parser (BS.pack str) of
+ Left txt -> Fail txt
+ Right x' -> if x' == x then Pass else Fail $ show x ++ " <<==>> " ++ show x'
+
+
+comparePosition :: (Position, String) -> Result
+comparePosition (pos, str) = let pos' = parsePosition str
+ in if pos' == pos then Pass else Fail $ show pos ++ " <<-->> " ++ show pos'
+
+compareCmdMsg :: (FicsMessage, String) -> Result
+compareCmdMsg (cmd, str) = case parseFicsMessage $ BS.pack str of
+ Left txt -> Fail txt
+ Right cmd' -> if cmd' == cmd then Pass else Fail $ show cmd ++ " <<-->> " ++ show cmd'
diff --git a/test/PlayersSpec.hs b/test/PlayersSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/PlayersSpec.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module PlayersSpec (spec) where
+
+import qualified Macbeth.Fics.Api.Rating as R
+import Macbeth.Fics.FicsMessage
+import Macbeth.Fics.Api.Player
+import Macbeth.Fics.Parsers.Players
+
+import Test.Hspec
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString.Char8 as BS
+
+
+spec :: Spec
+spec =
+ describe "Players" $ do
+
+ it "single player, Unregistered" $ parseOnly player' "++++^TeachMATE(U)\n"
+ `shouldBe` Right (Player R.Guest InvolvedInAGame (UserHandle "TeachMATE" [Unregistered]))
+
+ it "single player 2, with space" $ parseOnly player' "1173.kalithkar "
+ `shouldBe` Right (Player (R.Rating 1173 R.None) InactiveOrBusy (UserHandle "kalithkar" []))
+
+ it "single player, Admin & TournamentDirectorOrBot" $ parseOnly player' "----:adminBOT(*)(TD)"
+ `shouldBe` Right (Player R.Unrated NotOpenForMatch (UserHandle "adminBOT" [Admin,ServiceRepresentative]))
+
+ it "players" $ parseOnly players' "\n2985.BigMomma(C) ++++ xcx(U)\n1123^littledul \n\n 1055 players displayed (of 1055). (*) indicates system administrator.\n\ETB"
+ `shouldBe` Right [Player (R.Rating 2985 R.None) InactiveOrBusy (UserHandle "BigMomma" [Computer]),Player R.Guest NotBusy (UserHandle "xcx" [Unregistered]),Player (R.Rating 1123 R.None) InvolvedInAGame (UserHandle "littledul" [])]
+
+ it "check num players in block" $ fmap (\(Players x) -> length x) (parseOnly players "\NAK5\SYN146\SYN\n2985.BigMomma(C) ++++ xcx(U)\n1123^littledul \n\n 1055 players displayed (of 1055). (*) indicates system administrator.\n\ETB")
+ `shouldBe` Right 3
+
+ it "check num players in block 2" $ fmap (\(Players x) -> length x) (parseOnly players "\NAK5\SYN146\SYN\n2985.BigMomma(C) ++++ xcx(U)\n\n 1055 players displayed (of 1055). (*) indicates system administrator.\n\ETB")
+ `shouldBe` Right 2
+
+ it "bughouse partner offer" $ parseOnly partnerOffer "GuestZTCG offers to be your bughouse partner; type \"partner GuestZTCG\" to accept.\n"
+ `shouldBe` Right (PartnerOffer (UserHandle "GuestZTCG" []))
+
+ it "bughouse partner accepted" $ parseOnly partnerAccepted "GuestCCGS agrees to be your partner.\n"
+ `shouldBe` Right (PartnerAccepted (UserHandle "GuestCCGS" []))
+
+ it "bughouse partner declined" $ parseOnly partnerDeclined "GuestCCGS declines the partnership request.\n"
+ `shouldBe` Right (PartnerDeclined (UserHandle "GuestCCGS" []))
+
+ it "bughouse partner not open" $ parseOnly partnerNotOpen "\NAK6\SYN84\SYNzerowin is not open for bughouse.\n\ETB\n"
+ `shouldBe` Right (PartnerNotOpen (UserHandle "zerowin" []))
+
+ it "finger" $ parseOnly finger "\NAK6\SYN37\SYNFinger of raffa:\n\nOn for: 6 mins Idle: 13 secs\n(playing Who knew?\n\ETB\n"
+ `shouldBe` Right (Finger (UserHandle "raffa" []) "\n\nOn for: 6 mins Idle: 13 secs\n(playing Who knew?\n")
+
+ it "history" $ parseOnly history "\NAK6\SYN51\SYN\nHistory for Guffster:\n Opponent Type ECO End Date\n76: - 1337 B 1490 vitaliyS [ br 5 0] B06 Res Wed Feb 10, 18:29 EST 2016\n77: + 1348 W 1466 vitaliyS [ br 5 0] C23 Mat Wed Feb 10, 18:38 EST 2016\n\ETB"
+ `shouldBe` Right (History (UserHandle "Guffster" []) "\n Opponent Type ECO End Date\n76: - 1337 B 1490 vitaliyS [ br 5 0] B06 Res Wed Feb 10, 18:29 EST 2016\n77: + 1348 W 1466 vitaliyS [ br 5 0] C23 Mat Wed Feb 10, 18:38 EST 2016\n")
diff --git a/test/SeekSpec.hs b/test/SeekSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/SeekSpec.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SeekSpec (spec) where
+
+import Macbeth.Fics.Api.Api
+import Macbeth.Wx.Seek
+import Macbeth.Wx.GameType
+
+import Test.Hspec
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString.Char8 as BS
+
+seekInfo :: SeekInfo
+seekInfo = SeekInfo {
+ _category = Chess
+ , _board = Nothing
+ , _time = 5
+ , _inc = 10
+ , _rated = False
+ , _color = Nothing
+ , _manual = False
+ , _ratingFrom = 0
+ , _ratingTo = 9999
+}
+
+
+spec :: Spec
+spec =
+ describe "Seek widget" $ do
+
+ it "seekInfo to string" $ toString seekInfo `shouldBe` "5 10 u chess a 0-9999"
+ it "seekInfo to string, color=white" $ toString seekInfo {_color = Just White} `shouldBe` "5 10 u w chess a 0-9999"
+ it "seekInfo to string, color=white" $ toString seekInfo {_rated = True} `shouldBe` "5 10 r chess a 0-9999"
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}