Skip to content

Commit

Permalink
Sorting Games List
Browse files Browse the repository at this point in the history
  • Loading branch information
@tgass
tgass committed Aug 7, 2016
1 parent 3669c61 commit 73d15d8
Show file tree
Hide file tree
Showing 4 changed files with 88 additions and 34 deletions.
2 changes: 1 addition & 1 deletion macbeth-lib.cabal
View file
Expand Up @@ -6,7 +6,7 @@ maintainer: tilmann@macbeth-ficsclient.com
homepage: http://www.macbeth-ficsclient.com
bug-reports: https://github.com/tgass/macbeth/issues
category: game
version: 0.0.17
version: 0.0.19
cabal-version: >= 1.8
build-type: Simple
license: GPL
Expand Down
5 changes: 3 additions & 2 deletions src/Macbeth/Fics/Api/Game.hs
View file
Expand Up @@ -16,8 +16,9 @@ instance Show GameId where
instance Ord GameId where
compare (GameId gi1) (GameId gi2) = gi1 `compare` gi2

data GameType = Blitz | Lightning | Untimed | ExaminedGame | Standard | Wild | Atomic |
Crazyhouse | Bughouse | Losers | Suicide | NonStandardGame deriving (Show, Eq)
data GameType =
Lightning | Blitz | Standard | Wild | Atomic | Crazyhouse | Bughouse | Losers |
Suicide | Untimed | ExaminedGame | NonStandardGame deriving (Show, Eq, Ord)

data Game = Game {
gameId :: GameId
Expand Down
106 changes: 80 additions & 26 deletions src/Macbeth/Wx/GamesList.hs
View file
Expand Up @@ -3,20 +3,38 @@ module Macbeth.Wx.GamesList (
) where

import Macbeth.Fics.Api.Game
import Macbeth.Fics.FicsMessage
import Macbeth.Fics.FicsMessage hiding (gameId)
import Macbeth.Wx.Utils

import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ord
import Graphics.UI.WX hiding (refresh)
import Graphics.UI.WXCore
import System.IO

data GamesOpts = GamesOpts { refresh :: MenuItem ()
, showRated :: MenuItem ()
, showUnrated :: MenuItem ()
}
data CtxMenu = CtxMenu {
refresh :: MenuItem ()
, showRated :: MenuItem ()
, showUnrated :: MenuItem ()
, sortByGameId :: MenuItem ()
, sortByWhitesName :: MenuItem ()
, sortByWhitesRating :: MenuItem ()
, sortByBlacksName :: MenuItem ()
, sortByBlacksRating :: MenuItem ()
, sortByGameType :: MenuItem ()
}

data ListCfg = ListCfg {
games :: TVar [Game]
}

wxGamesList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())
wxGamesList glp h = do
cfg <- ListCfg <$> newTVarIO ([] :: [Game])
gl <- listCtrl glp [ columns :=
[ ("#", AlignLeft, -1)
, ("Player 1", AlignLeft, -1)
Expand All @@ -26,24 +44,34 @@ wxGamesList glp h = do
, ("Game type", AlignLeft, -1)
]]
listCtrlSetColumnWidths gl 100
set gl [on listEvent := onGamesListEvent gl h]

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)
ctxMenuPopup <- getGamesOpts glCtxMenu

listItemRightClickEvent gl $ \evt -> do
pt <- listEventGetPoint evt
menuPopup glCtxMenu pt gl

set (refresh ctxMenuPopup) [on command := hPutStrLn h "4 games"]
set (sortByGameId ctxMenuPopup) [ on command := displayGames gl ctxMenuPopup cfg]
set (sortByWhitesName ctxMenuPopup) [ on command := displayGames gl ctxMenuPopup cfg]
set (sortByWhitesRating ctxMenuPopup) [ on command := displayGames gl ctxMenuPopup cfg]
set (sortByBlacksName ctxMenuPopup) [ on command := displayGames gl ctxMenuPopup cfg]
set (sortByBlacksRating ctxMenuPopup) [ on command :=displayGames gl ctxMenuPopup cfg]
set (sortByGameType ctxMenuPopup) [ on command := displayGames gl ctxMenuPopup cfg]
set (showRated ctxMenuPopup) [on command := displayGames gl ctxMenuPopup cfg]
set (showUnrated ctxMenuPopup) [on command := displayGames gl ctxMenuPopup cfg]

return (gl, handler gl ctxMenuPopup cfg)


handler :: ListCtrl () -> CtxMenu -> ListCfg -> FicsMessage -> IO ()
handler gl ctx cfg cmd = case cmd of
Games games' -> do
atomically $ modifyTVar (games cfg) (const games')
displayGames gl ctx cfg

_ -> return ()


Expand All @@ -53,21 +81,47 @@ onGamesListEvent gl h evt = case evt of
_ -> return ()


filterGamesList :: ListCtrl () -> GamesOpts -> [Game] -> IO ()
filterGamesList gl opts games = do
displayGames :: ListCtrl () -> CtxMenu -> ListCfg -> IO ()
displayGames gl opts cfg = do
sortOrder <- sortFoo opts
games' <- sortBy sortOrder <$> readTVarIO (games cfg)

showRated' <- get (showRated opts) checked
showUnrated' <- get (showUnrated opts) checked
set gl [items := [ toList g | g <- games
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
sortFoo :: CtxMenu -> IO (Game -> Game -> Ordering)
sortFoo ctxMenu = do
gameId' <- flip whenMaybe (comparing gameId) <$> get (sortByGameId ctxMenu) checked
nameW' <- flip whenMaybe (comparing nameW) <$> get (sortByWhitesName ctxMenu) checked
ratingW' <- flip whenMaybe (comparing ratingW) <$> get (sortByWhitesRating ctxMenu) checked
nameB' <- flip whenMaybe (comparing nameB) <$> get (sortByBlacksName ctxMenu) checked
ratingB' <- flip whenMaybe (comparing ratingB) <$> get (sortByBlacksRating ctxMenu) checked
gameType'' <- flip whenMaybe (comparing (gameType . settings)) <$> get (sortByGameType ctxMenu) checked

return $ fromMaybe (comparing gameId)
(gameId' <|> nameW' <|> ratingW' <|> nameB' <|> ratingB' <|> gameType'')

whenMaybe :: Bool -> a -> Maybe a
whenMaybe x = (guard x >>) . Just


getGamesOpts :: Menu () -> IO CtxMenu
getGamesOpts ctxMenu = CtxMenu
<$> menuItem ctxMenu [ text := "Refresh" ]
<*> menuItem ctxMenu [ text := "Show rated games", checkable := True, checked := True]
<*> menuItem ctxMenu [ text := "Show unrated games", checkable := True, checked := True]
<*> (menuLine ctxMenu >>
menuRadioItem ctxMenu [ text := "Sort by Game Id"])
<*> menuRadioItem ctxMenu [ text := "Sort by White's Name"]
<*> menuRadioItem ctxMenu [ text := "Sort by White's Rating"]
<*> menuRadioItem ctxMenu [ text := "Sort by Black's Name"]
<*> menuRadioItem ctxMenu [ text := "Sort by Black's Rating"]
<*> menuRadioItem ctxMenu [ text := "Sort by Game Type"]


toList :: Game -> [String]
Expand Down
9 changes: 4 additions & 5 deletions src/Macbeth/Wx/PlayersList.hs
View file
Expand Up @@ -54,7 +54,10 @@ wxPlayersList slp h chan = do

ctxMenu <- menuPane []
ctxMenuPopup <- createCtxMenu ctxMenu
set (sortByName ctxMenuPopup) [checked := True]
set (sortByName ctxMenuPopup) [ on command := atomically (writeTVar (sortOrder cfg) Name) >> sortPlayers sl cfg
, checked := True ]
set (sortByStatus ctxMenuPopup) [ on command := atomically (writeTVar (sortOrder cfg) Status) >> sortPlayers sl cfg ]
set (sortByRating ctxMenuPopup) [ on command := atomically (writeTVar (sortOrder cfg) Rating) >> sortPlayers sl cfg ]

listItemRightClickEvent sl (\evt -> do
player <- listEventGetIndex evt >>= get sl . item
Expand All @@ -64,10 +67,6 @@ wxPlayersList slp h chan = do
set (observe ctxMenuPopup) [on command := hPutStrLn h $ "6 observe " ++ head player]
set (partner ctxMenuPopup) [on command := hPutStrLn h $ "6 partner " ++ head player]
set (chat ctxMenuPopup) [on command := writeChan chan $ Chat $ OpenChat (head player) Nothing ]
set (sortByName ctxMenuPopup) [on command := atomically (writeTVar (sortOrder cfg) Name) >> sortPlayers sl cfg ]
set (sortByStatus ctxMenuPopup) [on command := atomically (writeTVar (sortOrder cfg) Status) >> sortPlayers sl cfg ]
set (sortByRating ctxMenuPopup) [on command := atomically (writeTVar (sortOrder cfg) Rating) >> sortPlayers sl cfg ]

listEventGetPoint evt >>= flip (menuPopup ctxMenu) sl)

return (sl, handler sl cfg)
Expand Down

0 comments on commit 73d15d8

Please sign in to comment.