GUI.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}

---------
-- GUI -- 
---------

module GUI (gui, version) where

import Game               -- hiding (name)
import Graphics.UI.WX     hiding (bitmap, children, click, next, selections, stop)
import Graphics.UI.WXCore hiding (win)
import Data.Char
import Tools              hiding (field)
import Data.List

import Data.Version      (versionBranch)
import qualified Paths_GeBoP as Paths -- (version)


version :: String
version = a ++ "." ++ b ++ "." ++ c
  where
    (a : b : c : _) = map show $ versionBranch Paths.version ++ repeat 0


gui :: [GeneralGame] -> IO ()
gui games = do

  {--== CREATION PHASE ==--}
  
  f <- mdiParentFrame []
  c <- mdiParentFrameGetClientWindow f
  
  mGame  <- menuPane        []
  iNew   <- menuItem  mGame []
  ()     <- menuLine  mGame 
  iQuit  <- menuQuit  mGame []
 
  mHelp  <- menuHelp        []
  iHelp  <- menuItem  mHelp []
  iAbout <- menuAbout mHelp []

  field  <- statusField []

  logo   <- bitmapCreateLoad "images\\gebop.bmp" wxBITMAP_TYPE_ANY

  {--== DEFINITION PHASE ==--}
  
  let onpaint :: DC () -> Rect -> IO ()
      onpaint dc r = do
        tileBitmap dc r logo

  {--== MODIFICATION PHASE ==--}
  
  set mGame  [ text := "&Game"                                                      ]
  set iNew   [ text := "&New Game\tCtrl+N", help := "Start a new game"              , on command := newgame f games] 
  set iQuit  [                              help := "Quit the application"          , on command := close f] 
  set iHelp  [ text := "&Contents"        , help := "Show the contents of GeBoP"    , on command := html f "help\\index.html"]
  set iAbout [                              help := "Information about this program", on command := infoDialog f "About GeBoP" about]

  set f [ visible     := True
        , clientSize  := sz 640 480
        , picture     := "gebop.ico"
        , text        := "GeBoP"
        , menuBar     := [mGame, mHelp] 
        , statusBar   := [field]
        ]
  
  set c [ on paint    := onpaint
        , on resize  ::= repaint
        ]
  
  return ()

newgame :: MDIParentFrame () -> [GeneralGame] -> IO ()
newgame mdiparent games = do 
  mi <- askGame
  case mi of 
    Nothing -> return ()
    Just i  -> do
      let gc = games !! i
          pr = (\(Game g) -> standard g) gc
          ra = (\(Game g) -> possible g) gc
      msettings <- askSettings pr ra
      case msettings of 
        Nothing -> return ()
        Just settings -> do
          (\(Game g) -> game mdiparent g settings (newgame mdiparent games)) $ gc
          return ()
          
  where
  
    askGame :: IO (Maybe Int)
    askGame = do
      d   <- dialog     mdiparent [text := "Choose a game"]
      mes <- staticText d [text := "There are currently " ++ numberword (length games) ++ " games you can play."]
      ok  <- button     d [text := "Play", tooltip := "click to proceed"]
      can <- button     d [text := "Cancel", tooltip := "click to cancel"]
      r   <- radioBox   d Vertical (map (\(Game g) -> name g) games) [tooltip := "select a game"]
      set d [ layout := margin 4 $ column 4
              [ widget mes
              , hfill        $ widget r
              , hfloatCentre $ row 4 [widget ok, widget can]
              ]
            ]
      showModal d (\stop -> do
        set ok  [on command := get r selection >>= stop . Just]
        set can [on command := stop Nothing]
                            )
      
    askSettings :: Properties -> PropertyRange -> IO (Maybe Properties)
    askSettings pr ra = do
      let pra = playersrange ra
          bra = sort $ boardsizerange ra
      d <- dialog mdiparent [text := "Settings"]
      mes <- staticText d [text := "Select the settings."]
      ok  <- button     d [text := "Play", tooltip := "click to start the game"]
      can <- button     d [text := "Cancel", tooltip := "click to cancel"]
      cbs <- sequence $ replicate (maximum pra) $ checkBox d [tooltip := "should this player participate?"]
      sts <- sequence $ map (\i -> staticText d [text := "player " ++ show i]) [1 .. maximum pra]
      rbs <- sequence $ replicate (maximum pra) $ radioBox d Horizontal ["Human", "Computer"] [tooltip := "will you play this player?"]
      sequence_ $ map (\i -> set (cbs !!! (i - 1)) [enabled := False]) [1 .. minimum pra]
      let check b i = do set (cbs !!! (i - 1)) [checked := b]
                         set (sts !!! (i - 1)) [enabled := b]
                         set (rbs !!! (i - 1)) [enabled := b]
          click True  i | i `elem` pra = do for 1 i $ check True
                        | otherwise    = click True (i + 1)
          click False i | (i - 1) `elem` pra = do for i (maximum pra) $ check False
                        | otherwise          = click False (i - 1)
      for 1 (maximum pra) (\i -> check False i)
      click True $ players pr
      sequence_ $ zipWith (\i h -> set (rbs !!! (i - 1)) [selection := if h then 0 else 1]) [1 ..] (human pr)
      sequence_ $ map (\i -> set (cbs !!! (i - 1)) [on command ::= \cb -> get cb checked >>= flip click i]) [1 .. maximum pra]
      sli <- if length (bra) == 1 then return Nothing
             else fmap Just $ hslider d False 0 (length bra - 1) [selection := maybe 0 id $ elemIndex (boardsize pr) bra, tooltip := "select the size of the board"]
      let hcselection = map (\i -> [vfloatCentre $ widget $ cbs !!! (i - 1), vfloatCentre $ widget $ sts !!! (i - 1), widget $ rbs !!! (i - 1)]) [1 .. maximum pra]
          selections = case sli of
            Nothing -> grid 4 4 hcselection
            Just s  -> column 4 [ grid 4 4 hcselection
                                , hfill $ widget s
                                , row 4 [label "small", glue, label "large"]
                                ]
      set d [ layout := margin 4 $ column 4
              [ widget mes
              , selections
              , hfloatCentre $ row 4 [widget ok, widget can]
              ]
            ]
      showModal d (\stop -> do
        set ok  [on command := do
          p <- fmap (length . takeWhile id) $ sequence $ map (flip get checked) cbs
          h <- sequence $ (map.fmap) (== 0) $ map (flip get selection) rbs
          b <- case sli of Nothing -> return $ boardsize pr
                           Just s -> fmap (bra !!!) $ get s selection
          stop $ Just Properties {players = p, human = h, boardsize = b}]
        set can [on command := stop Nothing]
                            )

game :: Game g => MDIParentFrame () -> g -> Properties -> IO () -> IO ()
game mdiparent g pr newg = do

  {--== CREATION PHASE ==--}

  f <- mdiChildFrame mdiparent []
  
  mGame  <- menuPane         []
  iNew   <- menuItem  mGame  []
  iAgain <- menuItem  mGame  []
  ()     <- menuLine  mGame 
  iClose <- menuItem  mGame  []
  iQuit  <- menuQuit  mGame  []
  mBrain <- menuPane         []
  iOpen  <- menuItem  mBrain []
  mHelp  <- menuHelp         []
  iHelp  <- menuItem  mHelp  []
  iRules <- menuItem  mHelp  []
  iInfo  <- menuItem  mHelp  []
  iAbout <- menuAbout mHelp  []

  logoblue   <- bitmap "blue"
  logored    <- bitmap "red"
  logogreen  <- bitmap "green"
  logopurple <- bitmap "purple"
  logobrown  <- bitmap "brown"
  logogrey   <- bitmap "grey"

  turn   <- bitmap "turn"
  winner <- bitmap "winner"

  humanbmp    <- bitmap "human"
  computerbmp <- bitmap "computer"

  vart <- varCreate $ createtree g pr
  varb <- varCreate $ emptyBrain

  p <- panel f []

  clock <- timer f []
                    
  ps <- sequence $ replicate (players pr) $ panel f []
  ss <- sequence $ map (\p' -> hslider p' False 0 10 []) ps
  bs <- sequence $ map (\p' -> singleListBox p' []) ps

--{  field <- statusField []

  {--== DEFINITION PHASE ==--}

  let 
  
    stopClock :: IO ()
    stopClock = do timerStop clock
                   info "clock stopped"

    ifhuman :: IO () -> IO ()
    ifhuman io = do t <- getTree
                    if human pr !!! player t && movesnr t > 0 then io else return ()

    ifcomputer :: IO () -> IO ()
    ifcomputer io = do t <- getTree
                       if human pr !!! player t || movesnr t == 0 then return () else io
  
    getTree = varGet vart
    setTree = varSet vart
    updateTree = varUpdate vart
  
    logo :: Int -> Bitmap ()
    logo 0 = logoblue
    logo 1 = logored
    logo 2 = logogreen
    logo 3 = logopurple
    logo 4 = logobrown
    logo 5 = logogrey
    logo _ = error "logo: Unexpected value"
    
    onpaintplayer :: Int -> DC () -> Rect -> IO ()
    onpaintplayer i dc (Rect _x _y w _h) = do
      let xi = (w - 40) `div` 2
      drawBitmap dc (logo i) (pt xi 10) True []
      t <- getTree
      drawRect dc (Rect xi 60 40 40) [brushKind := BrushTransparent]
      for 0 (floor $ 19 * val t !!! i) (\j -> line dc (pt (xi + 1) (80 - j)) (pt (xi + 39) (80 - j)) [penColor := green])
      for (floor $ 18 * val t !!! i) 0 (\j -> line dc (pt (xi + 1) (80 - j)) (pt (xi + 39) (80 - j)) [penColor := red  ])
      line dc (pt xi 80) (pt (xi + 40) 80) []
      if player t == i && movesnr t > 0
        then drawBitmap dc turn (pt xi 110) True []
        else return ()
      drawBitmap dc (if human pr !!! i then humanbmp else computerbmp) (pt xi 160) True []
      ifIO (win i) $ drawBitmap dc winner (pt xi 110) True []

    oncommand i = do
      t <- getTree
      when (player t == i) $ send clock

    playerpanel i p' sli box = do
      but <- button p' []
      stt <- staticText p' []
      itemAppend box $ ""

      set sli [ clientSize := Size 60 20
              , color      := setLum 0.25 $ colorplayer i
              , bgcolor    := setLum 0.95 $ colorplayer i
              , on command := do v <- sliderGetValue sli
                                 set stt [text := show ((2 :: Int) ^ v) ++ " sec"]
              , visible    := not (human pr !!! i)
              , selection  := 3
              ]
      set stt [ clientSize := Size 70 20
              , text       := "8 sec"
              , color      := setLum 0.25 $ colorplayer i
              , bgcolor    := setLum 0.95 $ colorplayer i
              , visible    := not (human pr !!! i)
              ]
      set but [ text       := "move now"
              , color      := setLum 0.25 $ colorplayer i
              , bgcolor    := setLum 0.95 $ colorplayer i
              , on command := oncommand i
              , visible    := not (human pr !!! i)
              ] 
      set box [ clientSize := Size 60 20
              , color      := setLum 0.25 $ colorplayer i
              , bgcolor    := setLum 0.95 $ colorplayer i
              , on select  := do info ("select " ++ show i)
                                 s <- get box selection
                                 mapM_ (\b -> set b [selection := s]) bs
              ]
      set p' [ bgcolor    := setLum 0.95 $ colorplayer i
             , clientSize := Size 80 0
             , on paint   := onpaintplayer i
             , layout     := margin 4 $ column 4
               [ space 72 210
               , hfill                $ widget sli
               ,         hfloatCentre $ widget stt
               ,         hfloatCentre $ widget but
               , vfill $ hfloatCentre $ widget box
               ]
             ]
      return ()

    boxInsert :: Player -> String -> IO ()
    boxInsert p' s = do
      let b = (bs !!! p')
      i <- get b itemCount
      vs <- mapM (\p'' -> get (bs !!! p'') (item $ i - 1)) [p' .. length bs - 1]
      when (not $ all null vs) $
        mapM_ (\b' -> itemAppend b' "") bs
      i' <- get b itemCount
      set b [item (i' - 1) := s]
      mapM_ (\b' -> set b' [selection := i' - 1]) bs

    win :: Int -> IO Bool
    win i' = do
      t <- getTree
      return $ (movesnr t == 0) && (val t !!! i' == 1)

    gamename = (\(c : cs) -> toUpper c : cs) $ name g

    repaintall :: IO ()
    repaintall = do repaint p
                    sequence_ $ map repaint ps
  
    startClock :: IO ()
    startClock = do t <- getTree
                    v <- sliderGetValue $ ss !!! player t
                    let int = 1000 * 2 ^ v
                    _ <- timerStart clock int True
                    info "clock started"
                    
    next :: Int -> IO ()
    next n = do t <- getTree
                _ <- updateTree (shear n)
                u <- getTree
                b <- varGet varb
                bRefresh b
                boxInsert (player t) $ showmove pr (player t) (state t) (childid u)
                repaintall
                if movesnr t == 0
                  then do infoDialog f "End of Game" $ "The game ended with value " ++ show (val u)
                          info "end of this game"
                  else do ifcomputer $ info "computer's turn" >> think >> startClock
                          ifhuman $ info "player's turn"

    onidle :: IO Bool
    onidle = do ifcomputer $ do think
                                u <- getTree
                                when (movesnr u == 1) movenow
                                when (closed u) movenow
                --{ andere constructie (ook denken in spelertijd?)
                t <- getTree
                return $ human pr !!! player t

    think :: IO ()
    think = do t <- getTree
               js <- randomList
               let p' = path followcombination js t
--{               let p = path followbest js t
               _ <- updateTree $ step p'
               u <- getTree

               when (val t /= val u) $ sequence_ $ map repaint ps
               b <- varGet varb
               bUpdatePath b p'

               return ()

    movenow :: IO ()
    movenow = ifcomputer $ do
      stopClock
      t <- getTree
      i <- randomElement $ best t
      info "computer moves"
      next i

    newquick :: IO ()
    newquick = do stopClock
                  setTree $ createtree g pr
                  info "new game started"
                  sequence_ $ map (\b -> set b [items := [" "]]) bs
                  repaintall
                  ifcomputer $ info "computer's turn" >> startClock
                  return ()

    showRules :: IO ()
    showRules = html f $ "help\\rules_" ++ gamename ++ ".html"
    
    showInfo :: IO ()
    showInfo = html f $ "help\\info_" ++ gamename ++ ".html"

    playerinput :: Int -> IO ()
    playerinput i = do
      info $ "moverequest: " ++ show i
      ifhuman $ do
        t <- getTree
        when (0 <= i && i < movesnr t) $ info "correct move" >> next i

  {--== MODIFICATION PHASE ==--}

  sequence_ $ zipWith4 playerpanel [0..] ps ss bs

  board p pr vart True playerinput

  set mGame  [ text := "&Game"                                                                                                                                      ]
  set iNew   [ text := "&New Game\tCtrl+N"        , help := "Start a new game"                                 , on command := newg                                 ]
  set iAgain [ text := "Play &Again\tCtrl+A"      , help := "Play again with the same settings"                , on command := newquick >> varGet varb >>= bRefresh ]
  set iClose [ text := "&Close\tCtrl+C"           , help := "Close this game"                                  , on command := close f                              ]
  set iQuit  [                                      help := "Quit the application"                             , on command := close mdiparent                      ]
  set mBrain [ text := "&Brain"                                                                                                                                     ]
  set iOpen  [ text := "&Open\tCtrl+B"            , help := "Open the brain for " ++ gamename                  , on command := brain mdiparent pr vart varb newg    ]
  set iHelp  [ text := "&Contents"                , help := "Show the contents of GeBoP"                       , on command := html f "help\\index.html"            ]
  set iRules [ text := gamename ++ " &Rules"      , help := "Display the rules of this game"                   , on command := showRules                            ]
  set iInfo  [ text := gamename ++ " &Information", help := "Display some background information on this game" , on command := showInfo                             ]
  set iAbout [                                      help := "Information about this program"                   , on command := infoDialog f "About GeBoP" about     ]

  set clock [ on command := info "alarm" >> movenow ]

  set p [ clientSize := sz 400 400 ]

  set f [ text              := gamename
        , menuBar           := [mGame, mBrain, mHelp] 
        , layout            := row 0 ( fill (widget p)
                                     : map (vfill . widget) ps
                                     )
        , on idle           := onidle
        , picture           := "gebop.ico"
        , on closing        :~ \io -> do b <- varGet varb
                                         bClose b
                                         io
--{        , statusBar := [field]
        ]

  ifhuman $ stopClock

  return ()

data Brain
  = Brain { bClose      :: IO ()
          , bUpdatePath :: [Int] -> IO ()
          , bRefresh    :: IO ()
          }

emptyBrain :: Brain
emptyBrain
  = Brain { bClose      =         return ()
          , bUpdatePath = const $ return ()
          , bRefresh    =         return ()
          }

brain :: Game g => MDIParentFrame () -> Properties -> Var (Tree g) -> Var Brain -> IO () -> IO ()
brain mdiparent pr vart varb newg = do

  {--== CREATION PHASE ==--}

  let extraInfo = \_ -> return () -- "info" if you want tracing
  f <- mdiChildFrame mdiparent []
  extraInfo "mdiChildFrame"
  sw <- splitterWindow f []
  extraInfo "splitterWindow"
 
  pLeft  <- panel sw []
  pRight <- panel sw []
  pBoard <- panel pRight []
  pValue <- panel pRight []
  pInfo  <- panel pRight []
  extraInfo "panel"

  mGame  <- menuPane         []
  iNew   <- menuItem  mGame  []
  ()     <- menuLine  mGame
  iQuit  <- menuQuit  mGame  []
  mBrain <- menuPane         []
  iClose <- menuItem  mBrain []
  iMini  <- menuItem  mBrain []
  iLarge <- menuItem  mBrain []
  mHelp  <- menuHelp         []
  iHelp  <- menuItem  mHelp  []
  iBrain <- menuItem  mHelp  []
  iAbout <- menuAbout mHelp  []
  extraInfo "menu"

  logos  <- mapM (bitmap.nameplayer) [0 .. 5]
  winner <- bitmap "winner"
  leeg   <- bitmap "empty"

  bPlayer   <- staticBitmapCreate pRight (-1) (logos !!! 0) rectNull 0x00200000 -- 0x00200000 == wxBORDER_NONE
  extraInfo "staticBitmapCreate"

  -- tPlayer   <- staticText pRight []
  tMind     <- staticText pInfo []
  tMaxd     <- staticText pInfo []
  tVolume   <- staticText pInfo []
  extraInfo "staticText"

  tc <- treeCtrl pLeft []
  extraInfo "treeCtrl"

  g <- varGet vart >>= return . state
  varu <- varCopy vart

  {--== DEFINITION PHASE ==--}

  let 

    gamename :: String
    gamename = (\(c : cs) -> toUpper c : cs) $ name g

    getData :: TreeItem -> IO [Int]
    getData treeItem = do
      mmovs <- unsafeTreeCtrlGetItemClientData tc treeItem 
      case mmovs of Just movs -> return movs
                    Nothing   -> return []

    setImages :: Bool -> IO ()
    setImages True = do
      il <- imageListCreate (Size 40 40) True 0
      sequence_ $ map (bitmapImageList il) $ map nameplayer [0 .. 5]
      sequence_ $ map (bitmapHighImageList il) $ map nameplayer [0 .. 5]
      bitmapImageList il "brain"
      treeCtrlAssignImageList tc il
    setImages False = do
      il <- imageListCreate (Size 10 10) True 0
      sequence_ $ map (bitmapImageList il) $ map ("small_" ++) $ map nameplayer [0 .. 5]
      sequence_ $ map (bitmapHighImageList il) $ map ("small_" ++) $ map nameplayer [0 .. 5]
      bitmapImageList il "small_brain"
      treeCtrlAssignImageList tc il

    onmini :: IO ()
    onmini = do
      set f [clientSize := sz 256 100]
      splitterWindowSetSashPosition sw 128 True
   
    onpaintValue :: DC () -> Rect -> IO ()
    onpaintValue dc (Rect x y w_ h) = do
      let pl = players pr
          w = min (w_) (20 * pl)
          r = Rect x y w h
--{      line dc (pt 0 0) (pt w h) []
--{      line dc (pt 0 h) (pt w 0) []
      u <- varGet varu
      for 0 (pl - 1) (\i -> do
        let xi  = x + w * i `div` pl
            xi1 = x + w * (i + 1) `div` pl
        for 0 (floor $ 19 * val u !!! i) (\j -> line dc (pt (xi + 1) (20 - j)) (pt (xi1) (20 - j)) [penColor := colorplayer i])
        for (floor $ 18 * val u !!! i) 0 (\j -> line dc (pt (xi + 1) (20 - j)) (pt (xi1) (20 - j)) [penColor := setLum 0.4 $ colorplayer i])
        )
      drawRect dc r [brushKind := BrushTransparent]
      line dc (pt x 20) (pt (x + w) 20) []

    onTreeEvent :: EventTree -> IO ()
    onTreeEvent (TreeItemExpanding treeItem _veto) | treeItemIsOk treeItem = do
      wxcBeginBusyCursor
      children' <- treeCtrlGetChildren tc treeItem 
      mapM_ visualise children'
      wxcEndBusyCursor
      propagateEvent
    onTreeEvent (TreeSelChanged treeItem _olditem) | treeItemIsOk treeItem = do
      wxcBeginBusyCursor
      selectRight treeItem 
      wxcEndBusyCursor
      propagateEvent
    onTreeEvent _ = propagateEvent

    visualise :: TreeItem -> IO ()
    visualise treeItem = do
      c <- treeCtrlItemHasChildren tc treeItem 
      when (c == 0) $ giveBirth treeItem 
      updateThickness treeItem 
      updateImages treeItem 

    selectRight :: TreeItem -> IO ()
    selectRight treeItem = do
      updateRight treeItem 
      t <- varGet varu
      staticBitmapSetBitmap bPlayer (logos !!! player t)
      when (movesnr t == 0) $ staticBitmapSetBitmap bPlayer (if any (== 1) (val t) then winner else leeg)
      repaint pBoard

    updateRight :: TreeItem -> IO ()
    updateRight treeItem = do
      t <- gametree treeItem 
      varSet varu t
      set tMind     [text := "complete depth: " ++ show (mind     t)]
      set tMaxd     [text := "maximum depth: "  ++ show (maxd     t)]
      set tVolume   [text := "volume: "         ++ show (volume   t)]
      repaint pValue

    bClose' :: IO ()
    bClose' = close f

    bUpdatePath' :: [Int] -> IO ()
    bUpdatePath' path' = do
      root <- treeCtrlGetRootItem tc
      updatePath root path'
     where
      updatePath :: TreeItem -> [Int] -> IO ()
      updatePath treeItem path'' = do
        updateThickness treeItem 
        updateImages treeItem 
        ifIO (treeCtrlIsSelected tc treeItem) $ updateRight treeItem 
        ifIO (treeCtrlIsExpanded tc treeItem) $ case path'' of
          (i:is) -> do cs <- treeCtrlGetChildren tc treeItem 
                       updatePath (cs !! i) is
          [] -> return ()

    bRefresh' :: IO ()
    bRefresh' = do
      treeCtrlDeleteAllItems tc
--{      root <- treeCtrlAddRoot tc "current situation" 5 (-1) objectNull
      root <- treeCtrlAddRoot tc "current situation" 12 12 objectNull
      treeCtrlSetItemClientData tc root (return ()) []
      giveBirth root
      updateThickness root
      updateImages root
      treeCtrlSelectItem tc root
      selectRight root

    giveBirth :: TreeItem -> IO ()
    giveBirth treeItem = do
      movs <- getData treeItem 
      t <- gametree treeItem 
      for 0 (movesnr t - 1) (\i -> do
        let -- u = shear i t
            m = showmove pr (player t) (state t) i
--{        jtem <- treeCtrlAppendItem tc treeItem (show i ++ " (" ++ m ++ ")") (player t) (-1) objectNull 
        jtem <- treeCtrlAppendItem tc treeItem (show i ++ " (" ++ m ++ ")") (-1) (-1) objectNull 
        treeCtrlSetItemClientData tc jtem (return ()) (movs ++ [i])
        updateThickness jtem
        )
      treeCtrlSetItemHasChildren tc treeItem (movesnr t > 0)

    updateThickness :: TreeItem -> IO ()
    updateThickness treeItem = do
      t <- gametree treeItem 
      let itemcolor | filled t  = black
                    | otherwise = grey
      treeCtrlSetItemTextColour tc treeItem itemcolor
      treeCtrlSetItemBold       tc treeItem (closed t)
  
    updateImages :: TreeItem -> IO ()
    updateImages treeItem = do
      t <- gametree treeItem 
      c <- treeCtrlItemHasChildren tc treeItem 
      cs <- treeCtrlGetChildren tc treeItem 
      when (c > 0) $ for 0 (movesnr t - 1) (\i -> do
        let offset | i `elem` best t = 6
                   | otherwise       = 0
        setImage (cs !! i) (offset + player t)
        )

    setImage :: TreeItem -> Int -> IO ()
    setImage treeItem i = do
      j <- treeCtrlGetItemImage tc treeItem 0 --{ wxTreeItemIcon_Normal
      when (i /= j) $ do
        treeCtrlSetItemImage tc treeItem i 0 --{ wxTreeItemIcon_Normal
        treeCtrlSetItemImage tc treeItem i 1 --{ wxTreeItemIcon_Selected
--{        treeCtrlSetItemImage tc treeItem i 2 --{ wxTreeItemIcon_Expanded
--{        treeCtrlSetItemImage tc treeItem i 3 --{ wxTreeItemIcon_SelectedExpanded

--  gametree :: TreeItem -> IO (Tree g)
    gametree treeItem = do
      t <- varGet vart
      movs <- getData treeItem 
      return $ gametree_ movs t
     where
--    gametree_ :: [Int] -> Tree g -> Tree g
      gametree_ (i:is) t | i >= 0 && i < movesnr t = gametree_ is $ shear i t
      gametree_ _      t = t


    playerinput :: Int -> IO ()
    playerinput i = do
      info $ "brain moverequest: " ++ show i
      treeItem <- treeCtrlGetSelection tc
      t <- gametree treeItem 
      cs <- treeCtrlGetChildren tc treeItem 
      when (0 <= i && i < movesnr t) $ do
        treeCtrlExpand tc treeItem 
        treeCtrlSelectItem tc (cs !! i)

  {--== MODIFICATION PHASE ==--}

  board pBoard pr varu False playerinput

  bRefresh'
--  setImages True
  setImages False
        

  varSet varb $ Brain bClose' bUpdatePath' bRefresh'

  set mGame  [ text := "&Game"                                                                                                                                     ] 
  set iNew   [ text := "&New Game\tCtrl+N"        , help := "Start a new game"                                 , on command  := newg                               ]
  set iQuit  [                                      help := "Quit the application"                             , on command  := close mdiparent                    ] 
  set mBrain [ text := "&Brain"                                                                                                                                    ] 
  set iClose [ text := "&Close\tCtrl+C"           , help := "Close the brain for " ++ gamename                 , on command  := close f                            ]  
  set iMini  [ text := "&Minimal\tCtrl+M"         , help := "Minimize the brain size"                          , on command  := onmini                             ]  
  set iLarge [ text := "&Large Icons\tCtrl+L"     , checkable := True, checked := False                        , on command ::= (>>= setImages) . flip get checked ]  
  set iHelp  [ text := "&Contents"                , help := "Show the contents of GeBoP"                       , on command  := html f "help\\index.html"          ]
  set iBrain [ text := "The &Brain"               , help := "Shows help about the brain viewer"                , on command  := html f "help\\brain.html"          ]
  set iAbout [                                      help := "Information about this program"                   , on command  := infoDialog f "About GeBoP" about   ]

  set tc [ on treeEvent := onTreeEvent
         ] 

  set pLeft [ layout := fill $ widget tc
            ]

  set pValue [ clientSize := Size 40 40
             , on paint   := onpaintValue
             , on resize ::= repaint
             ]

  set pInfo [ layout := fill $ column 4 $
              [ widget tMind    
              , widget tMaxd    
              , widget tVolume    
              ]
            ]

  set pBoard [ on resize ::= repaint
             ] 

  set pRight [ layout := margin 4 $ column 4 $
               [ row 4 [widget bPlayer, fill $ widget pValue]
               , hfill $ widget pInfo
               ,  fill $ widget pBoard
               ]
             ]

  set f [ text              := gamename ++ " Brain"
        , menuBar           := [mGame, mBrain, mHelp] 
        , layout            := fill $ vsplit sw 4 200 (widget pLeft) (widget pRight)
        , picture           := "brain.ico"
        , clientSize        := Size 480 360
        , on closing        :~ (varSet varb emptyBrain >>)
        ]
        
colorplayer :: Int -> Color
colorplayer 0 = hsl 0.66 1   0.5
colorplayer 1 = hsl 0    1   0.5
colorplayer 2 = hsl 0.33 1   0.5
colorplayer 3 = hsl 0.82 1   0.5
colorplayer 4 = hsl 0.11 0.7 0.5
colorplayer 5 = hsl 0    0   0.5
colorplayer _ = hsl 0    0   0

nameplayer :: Int -> String
nameplayer 0 = "blue"
nameplayer 1 = "red"
nameplayer 2 = "green"
nameplayer 3 = "purple"
nameplayer 4 = "brown"
nameplayer 5 = "grey"
nameplayer _ = "black"

info :: String -> IO ()
info s = do
  putStrLn $ "[" ++ s ++ "]"
  return ()
  
html :: Window a -> FilePath -> IO ()
html w f = do
  d <- dialog w [text := "Help"]
  -- w <- htmlWindowCreate d (-1) (rect (point 0 0) (size 640 480)) 0 []
  w' <- htmlWindowCreate d (-1) (rect (point 0 0) (Size 640 480)) 0 []
  _  <- htmlWindowLoadPage w' f
  set d [layout := widget w', visible := True]
  return ()

about :: String
about = "GeBoP - General Boardgames Player"
     ++ "\nversion " ++ version
     ++ "\n"
     ++ "\nby Maarten Löffler"
     ++ "\nmloffler@cs.uu.nl"
     ++ "\n"
     ++ "\nGeBoP was written using wxHaskell"
     
bitmap :: String -> IO (Bitmap ())
bitmap name' = do bmp    <- bitmapCreateLoad ("images\\" ++ name' ++      ".bmp") wxBITMAP_TYPE_ANY
                  mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY 
                  bitmapSetDepth mskbmp 1
                  msk    <- maskCreate mskbmp
                  bitmapSetMask bmp msk
                  return bmp

bitmapImageList :: ImageList () -> String -> IO ()
bitmapImageList il name' = do
  bmp    <- bitmapCreateLoad ("images\\" ++ name' ++      ".bmp") wxBITMAP_TYPE_ANY
  mskbmp <- bitmapCreateLoad ("images\\" ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY 
  bitmapSetDepth mskbmp 1
  _ <- imageListAddBitmap il bmp mskbmp
  return ()

bitmapHighImageList :: ImageList () -> String -> IO ()
bitmapHighImageList il name' = do
  bmp    <- bitmapCreateLoad ("images\\high_" ++ name' ++      ".bmp") wxBITMAP_TYPE_ANY
  mskbmp <- bitmapCreateLoad ("images\\"      ++ name' ++ "_mask.bmp") wxBITMAP_TYPE_ANY 
  bitmapSetDepth mskbmp 1
  _ <- imageListAddBitmap il bmp mskbmp
  return ()