Index: src/GamePlay.hs =================================================================== --- src/GamePlay.hs (revision 21) +++ src/GamePlay.hs (revision 47) @@ -24,6 +24,7 @@ , randoms = randomStream (getSeed options) , roundNumber = 0 , foodAdmin = noFood { remaining = foodParticles, locations = foodPos } + , markerAdmin = noMarkerAdmin } populateWorld :: World -> IO (AntPositions, S.Set Pos, Int) @@ -73,4 +74,4 @@ do w <- gets world list <- liftIO $ getAssocs w i <- gets roundNumber - liftIO $ putStrLn ((unlines $ ("After round " ++ show i ++ "...") : map showCell list)) \ No newline at end of file + liftIO $ putStrLn ((unlines $ ("After round " ++ show i ++ "...") : map showCell list)) Index: src/Simulator.hs =================================================================== --- src/Simulator.hs (revision 21) +++ src/Simulator.hs (revision 47) @@ -25,6 +25,7 @@ , randoms :: [Int] , roundNumber :: Int , foodAdmin :: FoodAdmin + , markerAdmin :: MarkerAdmin } type Sim = StateT GameState IO @@ -196,9 +197,37 @@ ------------------------------------------------------------------ -- 2.5 Chemistry +data MarkerAdmin = MarkerAdmin + { locationsRed :: S.Set Pos + , locationsBlack :: S.Set Pos + } + +setMarkerAtPos :: AntColor -> Pos -> Sim () +setMarkerAtPos c pos = + case c of + Red -> changeMarkerAdmin (\s -> s { locationsRed = S.insert pos (locationsRed s)}) + Black -> changeMarkerAdmin (\s -> s { locationsBlack = S.insert pos (locationsBlack s)}) + +removeMarkerAtPos :: AntColor -> MarkerNumber -> Cell -> Pos -> Sim () +removeMarkerAtPos c m cell pos = + case c of + Red -> changeMarkerAdmin (\s -> s { locationsRed = if anyMarker (clearBit (markersRed cell) m) + then locationsRed s + else S.delete pos (locationsRed s)}) + Black -> changeMarkerAdmin (\s -> s { locationsBlack = if anyMarker (clearBit (markersBlack cell) m) + then locationsBlack s + else S.delete pos (locationsBlack s)}) + +changeMarkerAdmin :: (MarkerAdmin -> MarkerAdmin) -> Sim () +changeMarkerAdmin f = + modify (\s -> s { markerAdmin = f (markerAdmin s) }) + type MarkerNumber = Int -- 0..5 type Markers = Int8 +noMarkerAdmin :: MarkerAdmin +noMarkerAdmin = MarkerAdmin S.empty S.empty + noMarkers :: Markers noMarkers = 0 @@ -349,14 +378,16 @@ changeAnt (setState (if b then st1 else st2)) Mark i st -> - return $ - setMarkerAt (antColor ant) i . - changeAnt (setState st) - + do setMarkerAtPos (antColor ant) pos + return $ + setMarkerAt (antColor ant) i . + changeAnt (setState st) + Unmark i st -> - return $ - clearMarkerAt (antColor ant) i . - changeAnt (setState st) + do removeMarkerAtPos (antColor ant) i cell pos + return $ + clearMarkerAt (antColor ant) i . + changeAnt (setState st) PickUp st1 st2 | antHasFood ant || food cell == 0 -> @@ -493,4 +524,4 @@ changeCellAt f p = do arr <- gets world cell <- liftIO $ readArray arr p - liftIO (writeArray arr p (f cell)) \ No newline at end of file + liftIO (writeArray arr p (f cell)) Index: src/Ants.hs =================================================================== --- src/Ants.hs (revision 21) +++ src/Ants.hs (revision 47) @@ -16,6 +16,7 @@ import Data.List import qualified Data.Set as S import Data.Maybe +import Data.Bits import System.Time import Caching @@ -67,7 +68,7 @@ gameBoard <- scrolledWindow mainPanel [bgcolor :=white, scrollRate := sz 10 10, virtualSize := sz 1000 1000, size := sz 800 700] - (overviewPanel, roundNumberText, timeRemaining, scalingSlider) + (overviewPanel, roundNumberText, timeRemaining, scalingSlider, markerSwitch, markerSelector) <- makeOverviewPanel myOptions rightPanel (controlPanel, stopButton, stepButton, startButton, finishButton, speedSlider) @@ -104,7 +105,10 @@ set simulatorTimer [on command := timerHandler activeWidgets ref] set speedSlider [on command := speedHandler speedSlider ref] set scalingSlider [on command := scalingHandler scalingSlider gameBoard ref] - + set markerSwitch [on command := markerSwitchHandler markerSwitch markerSelector gameBoard ref] + set markerSelector [on select := markerHandler markerSelector gameBoard ref] + + -- initialization enableControl controlWidgets False updateInfo infoWidgets ref @@ -117,6 +121,8 @@ do p <- panel w [] -- create widgets scalingSlider <- hslider p False 160 400 [selection := 230] -- 5 10 50 -- pixels + markerSwitch <- checkBox p [checked := False] + markerSelector <- radioBox p Horizontal ["Black", "Red"] [enabled := False] roundNumberText <- staticText p [fontSize := 28, size := sz 40 20] timeRemaining <- staticText p [text := "unknown"] @@ -125,6 +131,7 @@ timeBox <- myBox p "Remaining time" rnrBox <- myBox p "Round number" zoomBox <- myBox p "Zoom in/out" + markBox <- myBox p "Show markers" -- set layout set p [layout := column 20 @@ -133,9 +140,12 @@ , rnrBox .^. widget roundNumberText , timeBox .^. widget timeRemaining , zoomBox .^. widget scalingSlider + , column 5 [hfill $ row 1 [widget markerSwitch, widget markBox] + , widget markerSelector + ] ]] -- return widgets - return (p, roundNumberText, timeRemaining, scalingSlider) + return (p, roundNumberText, timeRemaining, scalingSlider, markerSwitch, markerSelector) ----------------------------------------------------------------------------------- -- Control Panel @@ -189,6 +199,7 @@ paintHandler :: DC () -> GUI () paintHandler dc ref = do drawWorld dc ref + drawMarkers dc ref drawFood dc ref drawAnts dc ref @@ -237,6 +248,23 @@ setVirtualSize gameBoard ref repaint gameBoard +markerSwitchHandler :: CheckBox () -> RadioBox () -> ScrolledWindow () -> GUI () +markerSwitchHandler markerSwitch markerSelector gameBoard ref = + do val <- get markerSwitch checked + set markerSelector [ enabled := val ] + if not val + then do modifyIORef ref (\x -> x { marker = Nothing }) + repaint gameBoard + else markerHandler markerSelector gameBoard ref + +markerHandler :: RadioBox () -> ScrolledWindow () -> GUI () +markerHandler markerSelector gameBoard ref = + do val <- get markerSelector selection + let selectedMarker | val == 0 = Just Black + | otherwise = Just Red + modifyIORef ref (\x -> x { marker = selectedMarker }) + repaint gameBoard + ----------------------------------------------------------- -- GUI data @@ -249,6 +277,7 @@ , timing :: Timing , fasten :: Bool , cache :: Cache + , marker :: Maybe AntColor } createGUIData :: Options -> IO (IORef GUIData) @@ -263,6 +292,7 @@ , timing = Nothing , fasten = False , cache = myCache + , marker = Nothing } where scale = 1.01 ^^ (230 :: Int) @@ -313,6 +343,25 @@ [color := foodGreen, brushColor := foodGreen, brushKind := BrushSolid] mapM_ f posList +drawMarkers :: DC a -> GUI () +drawMarkers dc ref = do mark <- readFromIORef ref marker + case mark of + Nothing -> return () + Just Red -> drawMarkers' dc locationsRed markersRed ref + Just Black -> drawMarkers' dc locationsBlack markersBlack ref + +drawMarkers' :: DC a -> (MarkerAdmin -> S.Set Pos) -> (Cell -> Markers) -> GUI () +drawMarkers' dc locations markers ref = + do scale <- readFromIORef ref scaling + game <- readFromIORef ref gameState + let posList = S.elems (locations (markerAdmin game)) + f pos = do middle <- useCache (cellCentre pos) ref + cell <- readArray (world game) pos + let markerColor = markersToColor (markers cell) + circle dc middle (round (0.2*scale)) + [color := markerColor, brushColor := markerColor, brushKind := BrushSolid] + mapM_ f posList + foodRadius :: Float -> Int -> Int foodRadius scale = round . (/5) . (*scale) . sqrt . min 100 . fromIntegral @@ -441,3 +490,9 @@ foodGreen, niceBlue :: Color foodGreen = rgb 72 239 54 niceBlue = rgb 0 0 127 + +markersToColor :: Markers -> Color +markersToColor m = rgb (bitsToChannel m [5,4]) (bitsToChannel m [3,2]) (bitsToChannel m [1,0]) + where bitsToChannel m (b:bs) | testBit m b = 64 + (2 * bitsToChannel m bs) + | otherwise = (2 * bitsToChannel m bs) + bitsToChannel m [] = 0