Related
For an online algorithms course I am attempting to write a program which calculates the travelling salesman distance of cities using an approxomation algorithm:
Start the tour at the first city.
Repeatedly visit the closest city that the tour hasn't visited yet. In case of a tie, go to the closest city with the lowest
index. For example, if both the third and fifth cities have the
same distance from the first city (and are closer than any other
city), then the tour should begin by going from the first city to
the third city.
Once every city has been visited exactly once, return to the first city to complete the tour.
I am trying to write a solution in Haskell, and I have it working on small data sets, but it runs out of memory on a large input (the course has an input of ~33000 cities)
-- Fold data: cities map, distances map, visited map, list of visited cities and each distance,
-- and current city
data TS = TS (M.Map Int City) (M.Map (Int,Int) Double) (M.Map Int Bool) ([(Int,Double)]) (Int)
run :: String -> String
run input = let cm = parseInput input -- cityMap contains cities (index,xPos,yPos)
n = length $ M.keys cm
dm = buildDistMap cm -- distanceMap :: M.Map (Int,Int) Double
-- which is the distance between cities a and b
ts = TS cm dm (M.fromList [(1,True)]) [(1,0.0)] 1
(TS _ _ _ beforeLast _) = foldl' (\ts _ -> exec ts n) ts [2..n]
completed = end beforeLast dm
in show $ floor $ sum $ map (\(_,d) -> d) $ completed
exec :: TS -> Int -> TS
exec (TS cm dm visited ordered curr) n =
let candidateIndexes = [(i)|i<-[1..n],M.member i visited == False]
candidates = map (\i -> let (Just x) = M.lookup (curr,i) dm in (x,i)) candidateIndexes
(dist,best) = head $ sortBy bestCity candidates
visited' = M.insert best True visited
ordered' = (best,dist) : ordered
in TS cm dm visited' ordered' best
end :: [(Int,Double)] -> M.Map (Int,Int) Double -> [(Int,Double)]
end ordering dm = let (latest,_) = head ordering
(Just dist) = M.lookup (latest,1) dm
in (1,dist) : ordering
bestCity :: (Double,Int) -> (Double,Int) -> Ordering
bestCity (d1,i1) (d2,i2) =
if compare d1 d2 == EQ
then compare i1 i2
else compare d1 d2
At first I wrote the function exec as a recursive function instead of calling it via the foldl'. I thought changing it to use foldl' would solve my issue as foldl' is strict. However it appears to have made no difference in memory usage. I have tried compiling my program using no optimisations and -O2 optimisations.
I know that somehow it must be keeping multiple loops in memory as I can sort 34000 numbers without issue using
> sort $ [34000,33999..1]
What exactly am I doing wrong here?
Just in case it is any use here is the parseInput and buildDistMap functions, but they are not the source of my issue
data City = City Int Double Double deriving (Show, Eq)
-- Init
parseInput :: String -> M.Map Int City
parseInput input =
M.fromList
$ zip [1..]
$ map ((\(i:x:y:_) -> City (read i) (read x) (read y)) . words)
$ tail
$ lines input
buildDistMap :: M.Map Int City -> M.Map (Int,Int) Double
buildDistMap cm =
let n = length $ M.keys cm
bm = M.fromList $ zip [(i,i)|i<-[1..n]] (repeat 0) :: M.Map (Int,Int) Double
perms = [(x,y)|x<-[1..n],y<-[1..n],x/=y]
in foldl' (\dm (x,y) -> M.insert (x,y) (getDist cm dm (x,y)) dm) bm perms
getDist :: M.Map Int City -> M.Map (Int,Int) Double -> (Int,Int) -> Double
getDist cm dm (x,y) =
case M.lookup (y,x) dm
of (Just v) -> v
Nothing -> let (Just (City _ x1 y1)) = M.lookup x cm
(Just (City _ x2 y2)) = M.lookup y cm
in eDist (x1,y1) (x2,y2)
eDist :: (Double,Double) -> (Double,Double) -> Double
eDist (x1,y1) (x2,y2) = sqrt $ p2 (x2 - x1) + p2 (y2 - y1)
where p2 x = x ^ 2
And some test input
tc1 = "6\n\
\1 2 1\n\
\2 4 0\n\
\3 2 0\n\
\4 0 0\n\
\5 4 3\n\
\6 0 3"
data TS = TS (M.Map Int City) (M.Map (Int,Int) Double) (M.Map Int Bool) ([(Int,Double)]) (Int)
(TS _ _ _ beforeLast _) = foldl' (\ts _ -> exec ts n) ts [2..n]
exec :: TS -> Int -> TS
exec (TS cm dm visited ordered curr) n =
let ...
in TS cm dm visited' ordered' best
That foldl' is doing a lot less than you hope. It causes the TS constructor to be evaluated at every step, but nothing in that evaluation process requires visited', ordered', or best to be evaluated. (cm and dm aren't modified in the loop, so they can't stack up unevaluated thunks.)
The best way to solve this is to make the evaluation of the TS constructor returned by exec depend on evaluating visited', ordered', and best sufficiently.
M.Map is always spine-strict, so evaluating a map at all means the whole structure is evaluated. Whether the values are as well depends on how you imported it, but that turns out to not be relevant here. The value you're inserting is a nullary constructor, so it's already fully evaluated. So evaluating visited' to WHNF is sufficient.
Int is not a nested type, so evaluating best to WHNF is sufficient.
[(Int, Double)] (the outer parens are redundant, the list brackets do grouping of their contents) is a bit trickier. Lists aren't spine strict, nor are pairs strict. But looking at the construction pattern, this is a prepend-only structure. As such, you don't need to worry about the tail. If the list was evaluated coming in, the output will be evaluated as long as the new head is. Unfortunately, that means you've got to be a bit careful with the pair. Half of it is the same best value as constructed above, so that's not too bad. If it's evaluated, it's evaluated! (Though this does suggest you don't need to be passing it at every iteration, you could just use the front of ordered.) The other half of the pair is a Double, which is also non-nested, so WHNF is sufficient for it.
In this particular case, due to the fact that different approaches are necessary, I'd probably just approach this with seq.
let ... all the same stuff ...
in visited' `seq` dist `seq` best `seq` TS ... all the same stuff ...
Note that I'm being careful to force the minimal number of values to remove unnecessary nesting of thunks. The (,) and (:) constructors don't need to be evaluated, only their arguments - the place where nested thunks might build up. (What's the difference in memory consumption between <thunk <expression> <expression>> and <constructor <expression> <expression>>?)
Thanks to Carl for his extremely detailed answer. Also to Daniel for pointing out that caching the huge amounts of distances could actually be causing my memory issues. I was assuming because my code had got past that function that I had enough memory for that - forgetting Haskell is lazy and was only building that map in the exec function as I was actually using it.
I solved this problem now in a cleaner way. I am using a Data.Set of all the city indexes I still need to visit, and then because the cities were given in order of X values I know that the nearest cities on the plane will also be the nearest cities by index. Knowing this I set a value to take a slice from the set either side of the index at each iteration and use this slice to check for distances to my current city, and this allows me to calculate the distance to the next city at each iteration without caching that huge amount of data.
-- How many cities in each direction (index) to consider
-- smaller is faster but less accurate
searchWidth = 1000 :: Int
data TS = TS (M.Map Int City) (S.Set Int) [(Double,Int)] Int
run :: String -> String
run input =
let cm = parseInput input
n = length $ M.keys cm
toVisit = S.fromList [1..n]
ts = TS cm toVisit [(0.0,1)] 1
(TS _ _ beforeLast _) = foldl' (\ts i -> trace (concat [show i,"/",show n]) exec ts) ts [2..n]
afterLast = end cm beforeLast
in show $ floor $ sum $ map (\(d,_) -> d) afterLast
exec :: TS -> TS
exec (TS cm toVisit visited curr) =
let (Just (City _ cx cy)) = M.lookup curr cm
index = S.findIndex curr toVisit
toVisit' = S.deleteAt index toVisit
lb = let x = index - searchWidth in if x < 0 then 0 else x
ub = let x = index + searchWidth - lb in if x >= length toVisit' then (length toVisit') else x
candidateIndexes = S.take ub $ S.drop lb toVisit'
candidates = S.map (\i -> let (Just (City _ x y)) = M.lookup i cm in (eDist (x,y) (cx,cy),i)) candidateIndexes
(dist,next) = S.findMin candidates
visited' = (dist,next) : visited
in toVisit' `seq` dist `seq` next `seq` TS cm toVisit' visited' next
end :: M.Map Int City -> [(Double,Int)] -> [(Double,Int)]
end cm visited =
let (_,currI) = head visited
(Just (City _ cx cy)) = M.lookup currI cm
(Just (City _ lx ly)) = M.lookup 1 cm
dist = eDist (cx,cy) (lx,ly)
in (dist,1) : visited
Using a Data.Set also comes with the added bonus that it automatically sorts the values inside, making getting the next travel location trivial.
I realise this isn't the best Haskell code in the world and that I am doing some naughty things like matching Just straight out of map lookups rather than working with the Maybe values. Additionally it has been pointed out to me that I should be using a record rather than a data type to construct my TS
I have a list of pairs of views which represents list of content labels and their widths which I want to group in lines (if the next content label doesn't fit in line then put it into another line). So we have: viewList = [(View1, 45), (View2, 223.5), (View3, 14) (View4, 42)].
I want to write a function groupViews :: [a] -> [[a]] to group this list into a list of sublists where each sublist will contain only views with sum of widths less than the maximum specified width (let's say 250).
So for a sorted viewList this function will return : [[(View3, 14), (View4, 42), (View1, 45)],[(View2, 223.5)]]
It looks similar to groupBy. However, groupBy doesn't maintain an accumulator. I tried to use scanl + takeWhile(<250) combination but in this case I was able to receive only first valid sublist. Maybe use iterate + scanl + takeWhile somehow? But this looks very cumbersome and not functional at all. Any help will be much appreciated.
I would start with a recursive definition like this:
groupViews :: Double -> (a -> Double) -> [a] -> [[a]]
groupViews maxWidth width = go (0, [[]])
where
go (current, acc : accs) (view : views)
| current + width view <= maxWidth
= go (current + width view, (view : acc) : accs) views
| otherwise = go (width view, [view] : acc : accs) views
go (_, accs) []
= reverse $ map reverse accs
Invoked like groupViews 250 snd (sortOn snd viewList). The first thing I notice is that it can be represented as a left fold:
groupViews' maxWidth width
= reverse . map reverse . snd . foldl' go (0, [[]])
where
go (current, acc : accs) view
| current + width view <= maxWidth
= (current + width view, (view : acc) : accs)
| otherwise
= (width view, [view] : acc : accs)
I think this is fine, though you could factor it further if you like, into one scan to accumulate the widths modulo the max width, and another pass to group the elements into ascending runs. For example, here’s a version that works on integer widths:
groupViews'' maxWidth width views
= map fst
$ groupBy ((<) `on` snd)
$ zip views
$ drop 1
$ scanl (\ current view -> (current + width view) `mod` maxWidth) 0 views
And of course you can include the sort in these definitions instead of passing the sorted list from outside.
I don't know a clever way to do this just by combining functions from the standard library, but I do think you can do better than just implementing it from scratch.
This problem fits into a class of problems that I've seen before: "batch up items from this list somehow, and combine its items into batches according to some combination rule and some rule for deciding when a batch is too big". Years ago, when I was writing Clojure, I built a function that abstracted out this idea of batched combinations, just asking you to specify the rules for batching, and was able to use it in a surprising number of places.
Here's how I think it might be reimagined in Haskell:
glue :: Monoid a => (a -> Bool) -> [a] -> [a]
glue tooBig = go mempty
where go current [] = [current]
go current (x:xs) | tooBig x' = current : go x xs
| otherwise = go x' xs
where x' = current `mappend` x
If you had such a glue function already, you could build a simple data type with the appropriate Monoid instance (a list of objects and their cumulative sum), and then let glue do the heavy lifting:
import Data.Monoid (Sum(..))
data ViewGroup contents size = ViewGroup {totalSize :: size,
elements :: [(contents, size)]}
instance Monoid b => Monoid (ViewGroup a b) where
mempty = ViewGroup mempty []
mappend (ViewGroup lSize lElts) (ViewGroup rSize rElts) =
ViewGroup (lSize `mappend` rSize)
(lElts ++ rElts)
viewGroups = let views = [("a", 14), ("b", 42), ("c", 45), ("d", 223.5)]
in glue ((> 250) . totalSize) [ViewGroup (Sum width) [(x, Sum width)]
| (x, width) <- views]
main = print (viewGroups :: [ViewGroup String (Sum Double)])
[ViewGroup {totalSize = Sum {getSum = 101.0},
elements = [("a",Sum {getSum = 14.0}),
("b",Sum {getSum = 42.0}),
("c",Sum {getSum = 45.0})]},
ViewGroup {totalSize = Sum {getSum = 223.5},
elements = [("d",Sum {getSum = 223.5})]}]
On the one hand this looks like quite a bit of work for a simple function, but on the other it's rather nice to have a type that describes the cumulative summing you're doing, and Monoid instances are nice to have anyway...and after defining the type and the Monoid instance there's almost no work left to do in the calling of glue itself.
Well, I don't know, maybe it's still too much work, especially if you don't believe you can reuse that type. But I do think it's useful to recognize that this is a specific case of a more general problem, and try to solve the more general problem as well.
Given that groupBy and span themselves are defined by manual recursive functions, our modified functions will use the same mechanism.
Let us first define a general function groupAcc which takes an initial value for the accumulator, and then a function which takes an element in the list, the current accumulator state and potentially produces a new accumulated value (Nothing means the element is not accepted):
{-# LANGUAGE LambdaCase #-}
import Data.List (sortOn)
import Control.Arrow (first, second)
spanAcc :: z -> (a -> z -> Maybe z) -> [a] -> ((z, [a]), [a])
spanAcc z0 p = \case
xs#[] -> ((z0, xs), xs)
xs#(x:xs') -> case p x z0 of
Nothing -> ((z0, []), xs)
Just z1 -> first (\(z2, xt) -> (if null xt then z1 else z2, x : xt)) $
spanAcc z1 p xs'
groupAcc :: z -> (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc z p = \case
[] -> [] ;
xs -> uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
For our specific problem, we define:
threshold :: (Num a, Ord a) => a -> a -> a -> Maybe a
threshold max a z0 = let z1 = a + z0 in if z1 < max then Just z1 else Nothing
groupViews :: (Ord z, Num z) => [(lab, z)] -> [[(lab, z)]]
groupViews = fmap snd . groupAcc 0 (threshold 250 . snd)
Which finally gives us:
groupFinal :: (Num a, Ord a) => [(lab, a)] -> [[(lab, a)]]
groupFinal = groupViews . sortOn snd
And ghci gives us:
> groupFinal [("a", 45), ("b", 223.5), ("c", 14), ("d", 42)]
[[("c",14.0),("d",42.0),("a",45.0)],[("b",223.5)]]
If we want to, we can simplify groupAcc by assuming that z is a Monoid wherefore mempty may be used, such that:
groupAcc2 :: Monoid z => (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc2 p = \case
[] -> [] ;
xs -> let z = mempty in
uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
I've made a type which is supposed to emulate a "stream". This is basically a list without memory.
data Stream a = forall s. Stream (s -> Maybe (a, s)) s
Basically a stream has two elements. A state s, and a function that takes the state, and returns an element of type a and the new state.
I want to be able to perform operations on streams, so I've imported Data.Foldable and defined streams on it as such:
import Data.Foldable
instance Foldable Stream where
foldr k z (Stream sf s) = go (sf s)
where
go Nothing = z
go (Just (e, ns)) = e `k` go (sf ns)
To test the speed of my stream, I've defined the following function:
mysum = foldl' (+) 0
And now we can compare the speed of ordinary lists and my stream type:
x1 = [1..n]
x2 = Stream (\s -> if (s == n + 1) then Nothing else Just (s, s + 1)) 1
--main = print $ mysum x1
--main = print $ mysum x2
My streams are about half the speed of lists (full code here).
Furthermore, here's a best case situation, without a list or a stream:
bestcase :: Int
bestcase = go 1 0 where
go i c = if i == n then c + i else go (i+1) (c+i)
This is a lot faster than both the list and stream versions.
So I've got two questions:
How to I get my stream version to be at least as fast as a list.
How to I get my stream version to be close to the speed of bestcase.
As it stands the foldl' you are getting from Foldable is defined in terms of the foldr you gave it. The default implementation is the brilliant and surprisingly good
foldl' :: (b -> a -> b) -> b -> t a -> b
foldl' f z0 xs = foldr f' id xs z0
where f' x k z = k $! f z x
But foldl' is the specialty of your type; fortunately the Foldable class includes foldl' as a method, so you can just add this to your instance.
foldl' op acc0 (Stream sf s0) = loop s0 acc0
where
loop !s !acc = case sf s of
Nothing -> acc
Just (a,s') -> loop s' (op acc a)
For me this seems to give about the same time as bestcase
Note that this is a standard case where we need a strictness annotation on the accumulator. You might look in the vector package's treatment of a similar type https://hackage.haskell.org/package/vector-0.10.12.2/docs/src/Data-Vector-Fusion-Stream.html for some ideas; or in the hidden 'fusion' modules of the text library https://github.com/bos/text/blob/master/Data/Text/Internal/Fusion .
As practice, I am trying to write a simulation for the casino game "war" in Haskell.
http://en.wikipedia.org/wiki/Casino_war
It is a very simple game with a few rules. It would be an otherwise very simple problem to write in any of the imperative language I know, however I am struggling to write it in Haskell.
The code I have so far:
-- Simulation for the Casino War
import System.Random
import Data.Map
-------------------------------------------------------------------------------
-- stolen from the internet
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
fisherYates :: RandomGen g => g -> [a] -> ([a], g)
fisherYates gen [] = ([], gen)
fisherYates gen l = toElems $ Prelude.foldl
fisherYatesStep (initial (head l) gen) (numerate (tail l))
where
toElems (x, y) = (elems x, y)
numerate = zip [1..]
initial x gen = (singleton 0 x, gen)
-------------------------------------------------------------------------------
data State = Deal | Tie deriving Show
-- state: game state
-- # cards to deal
-- # cards to burn
-- cards on the table
-- indices for tied players
-- # players
-- players winning
-- dealer's winning
type GameState = (State, Int, Int, [Int], [Int], Int, [Int], Int)
gameRound :: GameState -> Int -> GameState
gameRound (Deal, toDeal, toBurn, inPlay, tied, numPlayers, pWins, dWins) card
| toDeal > 0 =
-- not enough card, deal a card
(Deal, toDeal - 1, 0, card:inPlay, tied, numPlayers, pWins, dWins)
| toDeal == 0 =
-- enough cards in play now
-- here should detemine whether or not there is any ties on the table,
-- and go to the tie state
let
dealerCard = head inPlay
p = zipWith (+) pWins $ (tail inPlay) >>=
(\x -> if x < dealerCard then return (-1) else return 1)
d = if dealerCard == (maximum inPlay) then dWins + 1 else dWins - 1
in
(Deal, numPlayers + 1, 0, [], tied, numPlayers, p, d)
gameRound (Tie, toDeal, toBurn, inPlay, tied, numPlayers, pWins, dWins) card
-- i have no idea how to write the logic for the tie state AKA the "war" state
| otherwise = (Tie, toDeal, toBurn, inPlay, tied, numPlayers, pWins, dWins)
-------------------------------------------------------------------------------
main = do
rand <- newStdGen
-- create the shuffled deck
(deck, _) <- return $ fisherYates rand $ [2 .. 14] >>= (replicate 6)
-- fold the state updating function over the deck
putStrLn $ show $ Prelude.foldl gameRound
(Deal, 7, 0, [], [], 6, [0 ..], 0) deck
-------------------------------------------------------------------------------
I understand why extra work has to go towards creating random numbers, but I am pretty sure I am missing some basic construct or concept. It shouldn't be this awkward to keep a collection of states, and run a branching logic over a list of input. I couldn't even figure out a good way to write the logic for the case where there are ties on the table.
I am not asking for complete solutions. It would be real nice if someone could point out what I am doing wrong, or some good reading materials that are relevant.
Thanks in advance.
A useful design pattern for maintaining application state is the so called state monad. You can find a description and some introductory examples here. Also, you might want to consider using a data type with named fields instead of a tuple for GameState, for example:
data GameState = GameState { state :: State,
toDeal :: Int
-- and so on
}
This will make it easier to access/update individual fields using record syntax.
To make the code more readable, you should break up the structure of the game into meaningful components, and reorganizing your code accordingly. What you've done is to put all the game's state into one data structure. The result is that you have to deal with all the game details all the time.
The game keeps track of scores for each player and the dealer. Sometimes it adds 1 or subtracts 1 from a score. Scores aren't used for anything else. Separate out the score management from the other code:
-- Scores for each player and the dealer
data Score = Score [Int] Int
-- Outcome for each player and the dealer. 'True' means a round was won.
data Outcome = Outcome [Bool] Bool
startingScore :: Int -> Score
startingScore n = Score (replicate n 0) 0
updateScore :: Outcome -> Score -> Score
updateScore (Outcome ps d) (Score pss ds) = Score (zipWith upd pss pos) (update ds d)
where upd s True = s+1
upd s False = s-1
The cards dealt are also associated with players and the dealer. Winning or losing a round is based only on the card values. Separate out the score computation from the other code:
type Card = Int
data Dealt = Dealt [Card] Card
scoreRound :: Dealt -> Outcome
scoreRound (Dealt ps dealerCard) = Outcome (map scorePlayer ps) (dealerCard == maximumCard)
where
maximumCard = maximum (dealerCard : ps)
scorePlayer p = p >= dealerCard
I would say a game round consists of all steps needed to produce a single Outcome. Reorganize the code accordingly:
type Deck = [Card]
deal :: Int -> Deck -> (Dealt, Deck)
deal n d = (Dealt (take n d) (head $ drop n d), drop (n+1) d) -- Should check whether deck has enough cards
-- The 'input-only' parts of GameState
type GameConfig =
GameConfig {nPlayers :: Int}
gameRound :: GameConfig -> Deck -> (Deck, Outcome)
gameRound config deck = let
(dealt, deck') = deal (nPlayers config) deck
outcome = scoreRound dealt
in (deck', outcome)
This covers most of what was in the original code. You can approach the rest in a similar way.
The main idea you should get is that Haskell makes it easy to decompose programs into small pieces that are meaningful on their own. That is what makes code easier to work with.
Instead of putting everything into GameState, I created Score, Outcome, Dealt, and Deck. Some of these data types came from the original GameState. Others were not in the original code at all; they were implicit in the way complicated loops were organized. Instead of putting the entire game into gameRound, I created updateScore, scoreRound, deal, and other functions. Each of these interacts with only a few pieces of data.
It occurred to me that the recommendation 'use StateT' might be a little opaque so I translated a bit into that jargon, hoping you could see how to go from there. It might be best to include the state of the deck in the game state. gameround below just restates your function in StateT lingo. The previous definition, game uses the deck field of the game state, continuously reduced, and contains the whole game. I introduce IO actions, just to show how it's done, and so you can see the succession of states if you call main in ghci. You 'lift' IO actions into the StateT machinery, to put them on a level with the gets and puts. Note that in mose subcases, we put the new state and then call for the action to be repeated, so that the do block contains the complete recursive operation. (Tie and an empty deck end the game immediately.) Then in the last line of main we runStateT on this self-updating game yielding a function GameState -> IO (GameState,()); then we feed this with a certain starting state including the randomly determined deck to get the IO action which is the main business. (I don't follow how the game is supposed to work, but was mechanically moving things around to get the idea across.)
import Control.Monad.Trans.State
import Control.Monad.Trans
import System.Random
import Data.Map
data Stage = Deal | Tie deriving Show
data GameState =
GameState { stage :: Stage
, toDeal :: Int
, toBurn :: Int
, inPlay :: [Int]
, tied :: [Int]
, numPlayers :: Int
, pWins :: [Int]
, dWins :: Int
, deck :: [Int]} deriving Show
-- deck field is added for the `game` example
type GameRound m a = StateT GameState m a
main = do
rand <- newStdGen
let deck = fst $ fisherYates rand $ concatMap (replicate 6) [2 .. 14]
let startState = GameState Deal 7 0 [] [] 6 [0 ..100] 0 deck
runStateT game startState
game :: GameRound IO ()
game = do
st <- get
lift $ putStrLn "Playing: " >> print st
case deck st of
[] -> lift $ print "no cards"
(card:cards) ->
case (toDeal st, stage st) of
(0, Deal) -> do put (first_case_update st card cards)
game -- <-- recursive call with smaller deck
(_, Deal) -> do put (second_case_update st card cards)
game
(_, Tie) -> do lift $ putStrLn "This is a tie"
lift $ print st
where -- state updates:
-- I separate these out hoping this will make the needed sort
-- of 'logic' above clearer.
first_case_update s card cards=
s { numPlayers = numPlayers s + 1
, pWins = [if x < dealerCard then -1 else 1 |
x <- zipWith (+) (pWins s) (tail (inPlay s)) ]
, dWins = if dealerCard == maximum (inPlay s)
then dWins s + 1
else dWins s - 1
, deck = cards }
where dealerCard = head (inPlay s)
second_case_update s card cards =
s { toDeal = toDeal s - 1
, toBurn = 0
, inPlay = card : inPlay s
, deck = cards}
-- a StateTified formulation of your gameRound
gameround :: Monad m => Int -> GameRound m ()
gameround card = do
s <- get
case (toDeal s, stage s) of
(0, Deal) ->
put $ s { toDeal = numPlayers s + 1
, pWins = [if x < dealerCard then -1 else 1 |
x <- zipWith (+) (pWins s) (tail (inPlay s)) ]
, dWins = if dealerCard == maximum (inPlay s)
then dWins s + 1
else dWins s - 1}
where dealerCard = head (inPlay s)
(_, Deal) ->
put $ s { toDeal = toDeal s - 1
, toBurn = 0
, inPlay = card : inPlay s}
(_, Tie) -> return ()
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
fisherYates :: RandomGen g => g -> [a] -> ([a], g)
fisherYates gen [] = ([], gen)
fisherYates gen l = toElems $ Prelude.foldl
fisherYatesStep (initial (head l) gen) (numerate (tail l))
where
toElems (x, y) = (elems x, y)
numerate = zip [1..]
initial x gen = (singleton 0 x, gen)
I was tried to write one random number generator implementation, based on number class. I also add there Monad and MonadPlus instance.
What mean "MonadPlus" and why I add this instance? Because of I want to use guards like here:
-- test.hs --
import RandomMonad
import Control.Monad
import System.Random
x = Rand (randomR (1 ::Integer, 3)) ::Rand StdGen Integer
y = do
a <-x
guard (a /=2)
guard (a /=1)
return a
here comes RandomMonad.hs file contents:
-- RandomMonad.hs --
module RandomMonad where
import Control.Monad
import System.Random
import Data.List
data RandomGen g => Rand g a = Rand (g ->(a,g)) | RandZero
instance (Show g, RandomGen g) => Monad (Rand g)
where
return x = Rand (\g ->(x,g))
(RandZero)>>= _ = RandZero
(Rand argTransformer)>>=(parametricRandom) = Rand funTransformer
where
funTransformer g | isZero x = funTransformer g1
| otherwise = (getRandom x g1,getGen x g1)
where
x = parametricRandom val
(val,g1) = argTransformer g
isZero RandZero = True
isZero _ = False
instance (Show g, RandomGen g) => MonadPlus (Rand g)
where
mzero = RandZero
RandZero `mplus` x = x
x `mplus` RandZero = x
x `mplus` y = x
getRandom :: RandomGen g => Rand g a ->g ->a
getRandom (Rand f) g = (fst (f g))
getGen :: RandomGen g => Rand g a ->g -> g
getGen (Rand f) g = snd (f g)
when I run ghci interpreter, and give following command
getRandom y (mkStdGen 2000000000)
I can see memory overflow on my computer (1G). It's not expected, and if I delete one guard, it works very fast. Why in this case it works too slow?
What I do wrong?
Your definition of (>>=) is certainly wrong, but I cannot point to where because it is so complicated! Instead I will explain why it cannot be defined correctly using an example. Consider:
Rand (\g -> (42,g)) >>= const mzero
We need to get that 42 out, so we need a g. The place to get the g is from the return value of the bind, so the answer is definitely:
Rand (\g -> ...)
For some ..., responsible for returning a (b,g) pair. Now that we have 42, we can evaluate const mzero 42 and find that we have RandZero But where are we going to get that b? It is nowhere (in fact, so nowhere in this example that it can be any type whatsoever, since the type of the expression is forall b. Rand b).
What is the purpose of RandZero for your monad? Are you just trying to make StateT g Maybe? My guess is that you are. In that case, you might have more luck trying to implement this type:
newtype Rand g a = Rand (g -> Maybe (a, g))
If I understand your "monad" correctly, (>>=) fails to be associative. Try defining
y' = do a <- do a' <- x
guard (a' /= 2)
return a'
guard (a /= 1)
return a
to check whether this is the case. Effectively, your backtracking strategy can only undo the last step, not the entire computation.