{- Graphical user interface module for Lost Cities game Pedro Vasconcelos , 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 ", "", "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