{-
Graphical user interface module for Lost Cities game
Pedro Vasconcelos <pbv@dcc.fc.up.pt>, 2009
Original card game designed by Reiner Knizia
-}
module GUI where
import Graphics.UI.WX hiding (play, when, Color)
import qualified Graphics.UI.WX (Color)
import Graphics.UI.WXCore hiding (when, Color)
import Control.Monad
import Data.Map (Map, (!))
import qualified Data.Map as Map
import LostCities hiding (dynamic)
import Utils
import List
import Text.Printf
-------------------------------------------------------------
-- setup the GUI
-- toplevel function
-------------------------------------------------------------
gui = do top <- frame [text := "Lost Cities", on paint := dcClearRect]
-- application menus
mainMenu <- menuPane [text := "&Game"]
menuQuit mainMenu [help := "Quit this program",
on command := close top]
helpMenu <- menuHelp []
rules <- menuItem helpMenu [text := "Rules",
help := "About the game rules",
on command := infoRules top]
about <- menuAbout helpMenu [help := "About this program",
on command := infoAbout top]
-- status field
status <- statusField [text := "Welcome to Lost Cities"]
set top [statusBar := [status], menuBar := [mainMenu, helpMenu]]
-- expedition and discard piles
p1 <- panel top [on paint := dcClearRect]
exps1<- sequence [newExpedition p1 [owner := Computer] | c<-colors]
exps2<- sequence [newExpedition p1 [owner := Human] | c<-colors]
discards <- sequence [newDiscard p1 [] | c<-colors]
deck <- newDeck p1 [enabled := False]
-- player's hand and buttons
p2 <- panel top [on paint := dcClearRect]
hand <- newHand p2 []
b1 <- button p2 [text := "Play"]
b2 <- button p2 [text := "Discard"]
-- setup initial game position
game <- newGame "Human" "Computer"
vgame <- varCreate game
-- display info message
let display msg = set status [text := msg]
-- perform some gameplay action
let withPlay action cont
= do g <- varGet vgame
case runPlay action g of
Left msg -> display msg
Right (_,g') -> do display ""
varSet vgame g'
cont g'
-- GUI update code
let updateDeck g
= set deck [decksize := length (drawPile g)]
let updateHand p
= set hand [cards := sort (playerHand p)]
let updateExpeditions exps p
= sequence_ [ set w [cards := reverse cs]
| (w,cs)<-zip exps (expeditionCards p)]
let updateDiscards g
= sequence_ [ set x [cards := [(c,v)|v<-vs]]
| (x,c,vs) <- zip3 discards colors (Map.elems (discard g))]
let updateCtls g
= do set b1 [enabled := (r==0)]
set b2 [enabled := (r==0)]
sequence_ [set d [enabled := (r==1)] | d<-discards]
set deck [enabled := (r==1)]
set hand [enabled := (r==0)]
where r = turn g `rem` 4 -- turn count remainer
-------------------------------------------
-- event handlers for buttons
-------------------------------------------
set b1 [on command :=
withSelection hand
(\i -> do cs<-get hand cards
withPlay (playAction1 (Play (cs!!i)))
(\g -> do updateHand (active g)
updateExpeditions exps2 (active g)
updateCtls g
)
)]
set b2 [on command :=
withSelection hand
(\i -> do cs<-get hand cards
withPlay (playAction1 (Discard (cs!!i)))
(\g -> do updateHand (active g)
updateDiscards g
updateCtls g))
]
-- click button handler for draw deck and discard piles
set deck [clickAction :=
withPlay (playAction2 DrawFromDeck >>
switchPlayer)
(\g -> do updateHand (other g)
updateDeck g
updateCtls g
display "Computer thinking..."
)]
sequence_ [set d [clickAction :=
withPlay (playAction2 (DrawFromDiscard c) >>
switchPlayer)
(\g -> do updateHand (other g)
updateDiscards g
updateCtls g
display "Computer thinking..."
)
]
| (c,d) <- zip colors discards]
-------------------------------------
-- timer event to play the computer
-------------------------------------
t <- timer top [interval := 1000]
set t [on command :=
do { g <- varGet vgame
; if endGame g then
do { let txt = showScore g
; display txt
; set t [enabled := False]
; infoDialog top "Game end" txt
; close top
}
else when (playing (active g) == Computer) $
do { m <- defaultAI g
; display ("Computer " ++ showMove m)
; let g'= runSafePlay' (play m) g
; updateExpeditions exps1 (other g')
; updateDiscards g'
; updateDeck g'
; updateCtls g'
; varSet vgame g'
}
}]
------------------------------
-- set board layout
------------------------------
set top [layout :=
column 8
[container p1 $
grid 0 0 $
[ [glue] ++
map (marginRight.alignBottom.vfill.widget) exps1
++ [glue],
[glue] ++
map (hfill.widget) discards
++ [marginLeft (hfill (widget deck))],
[glue] ++
map (marginRight.alignTop.vfill.widget) exps2
++ [glue]
]
, container p2 $
row 16 [glue, widget hand,
alignCenter (column 8 [widget b1,widget b2]), glue
]]]
--
updateDeck game
updateHand (active game)
where
-- miscelaneous dialogs
infoRules w = infoDialog w "About the game rules" $
init $
unlines ["Based on the Lost Cities card game by Reiner Knizia",
"Please visit the Boardgamegeek web page for reviews, rules and more information:",
"http://www.boardgamegeek.com/boardgame/50"]
infoAbout w
= infoDialog w "About this program" $
init $
unlines ["Copyleft 2009 Pedro Vasconcelos <pbv@ncc.up.pt>",
"",
"This program is free software distributed under the GNU Public License",
"Please see the included LICENSE file or visit my web page:",
"http://www.ncc.up.pt/~pbv/stuff/lostcities"]
-- show a move in textual form
showMove (a1,a2) = showAction1 a1 ++ " & " ++ showAction2 a2
showAction1 (Play (c,v)) = "played " ++ show c ++ " " ++ showFace v
showAction1 (Discard (c,v)) = "discarded " ++ show c ++ " " ++ showFace v
showAction2 DrawFromDeck = "drawn from deck"
showAction2 (DrawFromDiscard c) = "drawn from " ++ show c ++ " discard"
showFace v | v>0 = show v
| otherwise = "multiplier"
showScore g
= name p1 ++ ": " ++ show s1 ++ " points, " ++
name p2 ++ ": " ++ show s2 ++ " points."
where s1 = score p1
s2 = score p2
p1 = active g
p2 = other g
-- set cursor pointer for a window
cursorSet True = cursorHand
cursorSet False = cursorArrow
cursorHand w = do cursor <- cursorCreateFromStock wxCURSOR_HAND
windowSetCursor w cursor
return ()
cursorArrow w = do cursor <- cursorCreateFromStock wxCURSOR_ARROW
windowSetCursor w cursor
return ()
-----------------------------------------------------------------------------
-- custom widget classes
-- widgets with a card list attribute
class Cards w where
cards :: Attr w [Card]
-- widgets with a click action attribute
class ClickAction w where
clickAction :: Attr w (IO ())
-- custom widget for a hand of cards
data Hand = Hand { handWindow :: Panel ()
, handCards :: Var [Card]
, handSelection :: Var Int
, handDx :: Var Int
, handDy :: Var Int
, handAble :: Var Bool
}
-- attributes instances
instance Widget Hand where
widget h = widget (handWindow h)
instance Visible Hand where
-- refresh layout of hand widget
refresh h = do dx <- varGet (handDx h)
dy <- varGet (handDy h)
cs <- get h cards
-- let n = max 0 (length cs - 1)
let n = 7
let w = handWindow h
set w [layout := space (n*dx+cardWidth) (dy+cardHeight)]
repaint w
instance Able Hand where
enabled = newAttr "enabled" getter setter
where getter = varGet . handAble
setter = varSet . handAble
instance Selection Hand where
selection = newAttr "selection" getter setter
where getter h = varGet (handSelection h)
setter h sel = do varSet (handSelection h) sel
refresh h
-- perform some action with a selection
withSelection :: Selection w => w -> (Int -> IO ()) -> IO ()
withSelection w action
= do { i<-get w selection; when (i>=0) $ action i }
-- custom attribute: list of cards
instance Cards Hand where
cards = newAttr "cards" getter setter
where getter h = varGet (handCards h)
-- setting cards clears selection
setter h cs = do varSet (handCards h) cs
varSet (handSelection h) (-1)
refresh h
newHand :: Window a -> [Prop Hand] -> IO Hand
newHand parent props
= do vcards <- varCreate [] -- empty card list
vsel <- varCreate (-1) -- no selection
vdx <- varCreate (cardWidth`div`2) -- default gaps
vdy <- varCreate (cardHeight`div`6)
vable <- varCreate True
w <- panel parent []
let h = Hand w vcards vsel vdx vdy vable
set w [on resize := repaint w,
on paint := do_draw h,
on click := do_click h,
on enter := (\_ -> do able<-varGet vable
cursorSet able w)
]
set h props
refresh h
return h
where
-- draw method
do_draw h dc rect@(Rect x y _ _)
= do --dcClearRect dc rect
dx <- varGet (handDx h)
-- dy <- get h deltaY
dy <- dcGetTextHeight dc
varSet (handDy h) dy
cs <- get h cards
sel<- get h selection
-- draw the list of hand cards
let pts = [pt (x+k*dx) (y+h) | k<-[0..],
let h = if sel==k then 0 else dy]
drawCardlist (zip cs pts) dc
-- click method
do_click h (Point x y)
= do able <- get h enabled
when able $
do dx <- varGet (handDx h)
cs <- get h cards
let k = max (-1) $ min (x`div`dx) (length cs - 1)
set h [selection :~
(\sel -> if sel<0 then k
else if sel==k then (-1) else k)]
refresh h
-----------------------------------------------------------------------
-- custom widget for expeditions
-----------------------------------------------------------------------
data Expedition
= Expedition { expWindow :: Panel ()
, expCards :: Var [Card]
, expOwner :: Var Playing -- computer or human
}
instance Widget Expedition where
widget xp = widget (expWindow xp)
instance Visible Expedition where
-- recompute geometry
refresh exp = repaint w
where w = expWindow exp
instance Cards Expedition where
cards = newAttr "cards" getter setter
where getter exp = varGet (expCards exp)
setter exp cs = do varSet (expCards exp) cs
refresh exp
owner :: Attr Expedition Playing
owner = newAttr "owner" getter setter
where getter exp = varGet (expOwner exp)
setter exp p = do varSet (expOwner exp) p
refresh exp
newExpedition :: Window a -> [Prop Expedition] -> IO Expedition
newExpedition parent props
= do vcs <- varCreate []
vown <- varCreate Human
w <- panel parent []
let exp = Expedition w vcs vown
set w [layout := space cardWidth cardHeight,
on resize := repaint w,
on paint := do_draw exp]
set exp props
refresh exp
return exp
where
-- drawing method
--
do_draw exp dc rect@(Rect x y w h)
= do cs <- get exp cards
own <- get exp owner
-- inquire text height in current DC
dy <- dcGetTextHeight dc
let pts = case own of
Human -> [pt x (k*dy) | k<-[0..]]
Computer -> [pt x (h-cardHeight-k*dy) | k<-[0..]]
drawCardlist (zip cs pts) dc
set (expWindow exp) [tooltip := score_info cs]
-- scoring info
score_info [] = ""
score_info cs = show score ++ " points"
where score = scoreStack (map snd cs)
------------------------------------------------
-- custom widget for a discard pile
------------------------------------------------
data DiscardPile
= DiscardPile { discardWindow :: Panel ()
, discardPile :: Var [Card]
, discardAble :: Var Bool
, discardAction :: Var (IO ())
}
instance Widget DiscardPile where
widget d = widget (discardWindow d)
instance Visible DiscardPile where
refresh d = repaint (discardWindow d)
instance Able DiscardPile where
enabled = newAttr "enabled" getter setter
where getter = varGet . discardAble
setter = varSet . discardAble
instance Cards DiscardPile where
cards = newAttr "cards" getter setter
where getter = varGet . discardPile
setter d cs = do varSet (discardPile d) cs
refresh d
instance ClickAction DiscardPile where
clickAction = newAttr "clickAction" getter setter
where getter = varGet . discardAction
setter = varSet . discardAction
newDiscard :: Window a -> [Prop DiscardPile] -> IO DiscardPile
newDiscard parent props
= do w <- panel parent []
vpile <- varCreate []
vable <- varCreate True
vact <- varCreate (return ())
let d = DiscardPile w vpile vable vact
set w [ on resize := repaint w,
on paint := do_draw d,
on click := (\_ -> do able<-varGet vable
when able $
do {act<-varGet vact; act}),
on enter := (\_ -> do cs<-varGet vpile
able<-varGet vable
cursorSet (able && not (null cs)) w
)
]
set d props
set w [layout := space cardWidth cardHeight]
refresh w
return d
where
do_draw d dc r@(Rect x y _ _)
= do drawRect dc r [brush := brushSolid boardBgcolor,
pen := penTransparent]
cs <- get d cards
-- only draw the top card (list head)
drawCardlist (zip cs [pt x y]) dc
----------------------------------------
-- custom widget for a deck of cards
----------------------------------------
data Deck = Deck { deckWindow :: Panel ()
, deckSize :: Var Int
, deckAble :: Var Bool
, deckAction :: Var (IO ())
}
instance Widget Deck where
widget d = widget (deckWindow d)
-- re-fit deck layout
instance Visible Deck where
refresh d = do n<-varGet (deckSize d)
let k = ceiling (fromIntegral n/10)
let w = deckWindow d
set w [layout := space (cardWidth+2*k) (cardHeight+2*k),
tooltip := show n ++ " cards left"]
repaint w
instance Able Deck where
enabled = newAttr "enabled" getter setter
where getter = varGet . deckAble
setter = varSet . deckAble
instance ClickAction Deck where
clickAction = newAttr "clickAction" getter setter
where getter = varGet . deckAction
setter = varSet . deckAction
-- custom attribute: number of cards left
decksize :: Attr Deck Int
decksize = newAttr "decksize" getter setter
where getter d = varGet (deckSize d)
setter d n = do varSet (deckSize d) n
refresh d
newDeck :: Window a -> [Prop Deck] -> IO Deck
newDeck parent props
= do vsize <- varCreate 0
vable <- varCreate True
vact <- varCreate (return ())
w <- panel parent []
let d = Deck w vsize vable vact
set w [on resize := repaint w,
on paint := do_draw d,
on click := (\_ -> do able<-varGet vable
when able $ do {act<-varGet vact; act}),
on enter := (\_ -> do able<-varGet vable
cursorSet able w)
]
set d props
refresh d
return d
where
-- drawing method
do_draw d dc rect@(Rect x y _ _)
= do --dcClearRect dc rect
n <- get d decksize
let k = ceiling (fromIntegral n/10)
let pts = [pt (x+2*i) (y+2*i) | i<-[0..k-1]]
sequence_ [draw_back dc pt | pt<-pts]
-- draw a card back
draw_back dc pt
= do roundedRect dc r cardRadius [penColor := cardBgcolor,
brush := brushSolid cardBgcolor]
roundedRect dc r cardRadius [penColor := black,
brushColor := black,
brushKind := BrushHatch HatchCrossDiag]
where r = Rect x y cardWidth cardHeight
x = pointX pt
y = pointY pt
-------------------------------------------------------------------
-- auxiliary code
-------------------------------------------------------------------
-- inquire text height in current DC
dcGetTextHeight dc = liftM sizeH $ getTextExtent dc "X"
-- draw an overlapping list of cards
drawCardlist cardpts dc
= do dcSetBrushStyle dc (brushSolid black)
dcSetFontStyle dc myFont
-- maximum numeral text extent
sz <- getTextExtent dc "99"
sequence_ [drawCard card dc sz pt | (card,pt) <- cardpts]
where
myFont = fontSwiss { _fontWeight=WeightBold }
-- draw a single card
drawCard card@(c,v) dc sz p
= do roundedRect dc r0 cardRadius [brushColor:=black, penColor:=white]
drawRect dc r1 [brushColor:=wxc, penColor:=wxc]
sequence_ [drawText dc txt p [textColor:= wxc]
| p <- pts]
where r0 = Rect x y cardWidth cardHeight
r1 = Rect (x+2) (y+h) (cardWidth-4) (cardHeight-2*h)
pts = [pt (x+2) (y+1), pt (x+cardWidth-w-2) (y+1), pt (x+2)
(y+cardHeight-h), pt (x+cardWidth-w-2) (y+cardHeight-h)]
w = sizeW sz
h = sizeW sz
x = pointX p
y = pointY p
txt = showFace v
wxc = wxColor c
-- convert card color to wxWidgets color
wxColor :: Color -> Graphics.UI.WX.Color
wxColor White = white
wxColor Yellow = yellow
wxColor Red = red
wxColor Green = green
wxColor Blue = myblue
where myblue = colorRGB 0 220 255 -- reads better over black bg
-- convert a card face value to a string
showFace :: Int -> String
showFace n | n==0 = " X" -- multiplication sign
| otherwise = printf "%2d" n
{-
Alternative symbols for investment cards:
check marks: U+2713, U+2714
multiplication sign: U+2715, U+2716, U+2718
ballot marks: U+2717, U+2718
signing hands: U+F02D U+270D U+E41E U+E01B
-}
cardWidth, cardHeight :: Int
cardWidth = 60
cardHeight = 90
cardRadius :: Double
cardRadius = 5
-- background color for board and cards
boardBgcolor = colorRGB 160 82 45
cardBgcolor = colorRGB 200 190 150