From 6a46a5cfcb76f7a76c3c0dab343257f1e8b39e6e Mon Sep 17 00:00:00 2001 From: Neill Bogie Date: Sun, 12 May 2013 14:58:43 +0100 Subject: [PATCH] Switch to pure functions for random board gen. --- Game.hs | 25 +++++++++++++------------ Gui.hs | 25 +++++++++++++------------ Shuffle.hs | 34 +++++++++++++++++----------------- 3 files changed, 43 insertions(+), 41 deletions(-) diff --git a/Game.hs b/Game.hs index 87334ae..4113426 100644 --- a/Game.hs +++ b/Game.hs @@ -117,18 +117,18 @@ legalMovesInDirection b origPos d = else [] where nextPos = nextPosition origPos d -addRandomPlayers :: Int -> Board -> IO Board -addRandomPlayers nPieces b = do - rndPosns <- shuffleIO (vacantPositions b) - let pps = zip (cycle players) (take nPieces rndPosns) - return $ updatePosStateMap (\m -> foldl addPlayerAtPos m pps) b - -initRandomBoard :: Int -> Int -> Int -> IO Board -initRandomBoard w h nPieces = do - rndNs <- fmap (randomRs (1,3)) getStdGen - let b = Board (w, h) Player1 initScoreMap (initPSM rndNs) - addRandomPlayers nPieces b +addRandomPlayers :: RandomGen g => g -> Int -> Board -> (Board, g) +addRandomPlayers g nPieces b = (b', g') + where + (rndPosns, g') = shuffle g (vacantPositions b) + b' = updatePosStateMap (\m -> foldl addPlayerAtPos m pps) b + pps = zip (cycle players) (take nPieces rndPosns) + +initRandomBoard :: RandomGen g => g -> Int -> Int -> Int -> (Board, g) +initRandomBoard g w h nPieces = addRandomPlayers g nPieces b where + rndNs = randomRs (1,3) g + b = Board (w, h) Player1 initScoreMap (initPSM rndNs) initScoreMap = M.fromList (zip players (repeat 0)) initPSM iceNs = M.fromList (zip hexGrid (map mkpos iceNs)) where @@ -327,10 +327,11 @@ main = nonguimain nonguimain :: IO Board nonguimain = do args <- getArgs + gen <- getStdGen case args of [w,h,nPieces,strat1,strat2,logLevel] -> do let logging = (read logLevel) - b <- initRandomBoard (read w) (read h) (read nPieces) + let (b, _gen') = initRandomBoard gen (read w) (read h) (read nPieces) when (logging <= Info) $ putStrLn $ "Starting with strategies: " ++ strat1 ++ ", " ++ strat2 ++ " on a board of dimensions " ++ show (w,h) ++ " with " ++ show nPieces ++ " pieces" autoplay logging (stratFor $ read strat1) (stratFor $ read strat2) b diff --git a/Gui.hs b/Gui.hs index 92402d4..3f4e447 100644 --- a/Gui.hs +++ b/Gui.hs @@ -1,13 +1,15 @@ module Gui where -import Graphics.Gloss import qualified Data.Map as M import Game hiding (main) import Graphics.Gloss.Interface.Pure.Game +import System.Random(getStdGen,StdGen) + +initStandardRandomBoard gen = initRandomBoard gen 6 6 4 main = guimain guimain = do - - (start:bs) <- mapM (const $ initRandomBoard 6 6 4) ([1..9]::[Int]) + gen <- getStdGen + let (start, gen') = initStandardRandomBoard gen -- http://hackage.haskell.org/packages/archive/gloss/1.7.8.2/doc/html/Graphics-Gloss.html#v:play play (InWindow "Penguins, Fish, Ice - Haskell UI" --name of the window @@ -16,13 +18,13 @@ guimain = do ) backgroundColor -- background colour 30 -- number of simulation steps to take for each second of real time - (initialGameState start bs) -- the initial world + (initialGameState start gen') -- the initial world drawStateMgr -- A function to convert the world into a picture handleInputMgr -- A function to handle input events (const id) -initialGameState :: Board -> [Board] -> GS -initialGameState start bs = (GS start [] bs [] handleSelect [] SplashScreen) +initialGameState :: Board -> StdGen -> GS +initialGameState start gen = (GS start [] [] handleSelect [] SplashScreen gen) drawStateMgr :: GS -> Picture drawStateMgr gs = draw (gameMode gs) $ gs @@ -75,16 +77,16 @@ logMsg gs msg = gs { logs = take 5 (msg : logs gs) } backgroundColor = colorSea -- dark $ dark $ dark blue -- makeColor8 200 200 200 100 type ClickHandler = Event -> GS -> GS --- (board in play, undo list, fresh boards, log msgs) + data GameMode = SplashScreen | GamePlay deriving (Show, Eq) data GS = GS { b :: Board , undos :: [Board] - , nextBoards :: [Board] , logs :: [String] , clickHdlr :: ClickHandler , hilitPosition :: [Position] , gameMode :: GameMode + , rndGen :: StdGen } resetHandlers gs = gs { clickHdlr = handleSelect, hilitPosition = [] } @@ -110,9 +112,8 @@ handleChar 'b' gs = , logs = ("best move scored " ++ show i):logs gs } where (i, b') = makeBestMoveIfUnfinished (b gs) -handleChar 'n' gs = case nextBoards gs of - [] -> gs - (next:others) -> gs { b = next, nextBoards = others, undos = [] } +handleChar 'n' gs = gs { b = next, undos = [], rndGen = gen' } + where (next,gen') = initStandardRandomBoard (rndGen gs) handleChar 'a' gs = case undos gs of [] -> gs @@ -140,7 +141,7 @@ help = [ "---- Keys -------------" , "b - make Best move" , "a - start same board Again" , "u - Undo move" - , "n - New board (limited)" ] + , "n - New board" ] drawPlayingArea :: Board -> [Position] -> Picture drawPlayingArea bd hilitPosns = diff --git a/Shuffle.hs b/Shuffle.hs index 9ed928b..e534014 100644 --- a/Shuffle.hs +++ b/Shuffle.hs @@ -1,22 +1,22 @@ -- http://www.haskell.org/haskellwiki/Random_shuffle -module Shuffle where +module Shuffle (shuffle) where import System.Random -import Data.Array.IO -import Control.Monad +import Data.Map hiding (foldl) + +fisherYatesStep :: RandomGen g => (Map Int a, g) -> (Int, a) -> (Map Int a, g) +fisherYatesStep (m, gen) (i, x) = ((insert j x . insert i (m ! j)) m, gen') + where + (j, gen') = randomR (0, i) gen --- | Randomly shuffle a list --- /O(N)/ -shuffleIO :: [a] -> IO [a] -shuffleIO xs = do - ar <- nuArray n xs - forM [1..n] $ \i -> do - j <- randomRIO (i,n) - vi <- readArray ar i - vj <- readArray ar j - writeArray ar j vi - return vj +fisherYates :: RandomGen g => g -> [a] -> ([a], g) +fisherYates gen [] = ([], gen) +fisherYates gen l = + toElems $ foldl fisherYatesStep (initial (head l) gen) (numerate (tail l)) where - n = length xs - nuArray :: Int -> [a] -> IO (IOArray Int a) - nuArray len ys = newListArray (1,len) ys + toElems (x, y) = (elems x, y) + numerate = zip [1..] + initial x g = (singleton 0 x, g) + +shuffle :: RandomGen g => g -> [a] -> ([a], g) +shuffle = fisherYates