I am writing a random walk program in Haskell. The basic idea is generating a series of points, randomly at first, then let these points move randomly to next positions and so on. However, I can't let the function iterate, because it can't remember the previous computed value. How to solve this ?
The following is the code I wrote. The problem is that every time it only starts moving from the positions I gave initially.
import Graphics.Gloss
import System.Random
draw :: IO ()
draw = animate FullScreen white (picture [(1,2),(2,5),(4,7),(3,3)])
picture :: [Point] -> Float -> Picture
picture origin num = pictures [translate x y (circle 10) | (x,y) <- randomNext (round num) origin]
randomNext :: Int -> [Point] -> [Point]
randomNext num origin = zipWith (\(x1,y1) (x2,y2) -> (x1+x2,y1+y2)) r origin
where r = zip (oner num) (oner (num+1))
oner n = take (length origin) $ randomRs (-5::Float,5) (mkStdGen n)
If we rewrite slightly your randomNext function using more conventional notations and shorter lines, it gives something like this:
import System.Random
type Point = (Float, Float)
nextRandoms1 :: Int -> [Point] -> [Point]
nextRandoms1 seed origins =
let add2d = (\(x1,y1) (x2,y2) -> (x1+x2, y1+y2))
count = length origins
range = (-5::Float, 5)
xs = take count $ randomRs range (mkStdGen (seed+0))
ys = take count $ randomRs range (mkStdGen (seed+1))
in
zipWith add2d origins (zip xs ys)
As you have noted, the function does not return anything to allow for the generation of more random values.
More subtly, it uses 2 distinct random series with adjacent seed values. But the library does not offer any guarantee that these 2 series are uncorrelated. Indeed, some random number generators use their seed as just an offset into a shared very large pseudo-random sequence.
Secondarily, it deals with both generating the position increments and adding them to the initial positions.
To avoid these problems, we could start with a modified function which follows the common convention of taking an initial random generator state, and returning an updated state as part of the result:
randomPointUpdates :: StdGen -> (Float, Float) -> Int -> ([Point], StdGen)
randomPointUpdates gen0 range count =
if (count <= 0)
then ([], gen0) -- generator unaltered
else
let (dx, gen1) = randomR range gen0
(dy, gen2) = randomR range gen1
point = (dx, dy)
(rest, gen) = randomPointUpdates gen2 range (count-1)
in
(point : rest, gen)
This randomPointUpdates function uses recursion on the number of points. It just generates 2D position increments and does not deal with addition at all.
On top of this function, we can now write another one that does deal with addition. As the range is left hardwired, it takes just two arguments: the initial generator state, and the list of initial point positions:
nextRandoms :: StdGen -> [Point] -> ([Point], StdGen)
nextRandoms gen0 origins =
let add2d = (\(x1,y1) (x2,y2) -> (x1+x2, y1+y2))
count = length origins
range = (-5::Float, 5)
(changes, gen1) = randomPointUpdates gen0 range count
points = zipWith add2d origins changes
in
(points, gen1)
We can test that second function using the ghci interpreter:
λ>
λ> :load q66762139.hs
Ok, one module loaded.
λ>
λ> origins = [(1,2),(2,5),(4,7),(3,3)] :: [Point]
λ> gen0 = mkStdGen 4243
λ>
λ> fst $ nextRandoms gen0 origins
[(3.8172607,-0.54611135),(4.0293427,6.095909),(-0.6763873,6.4596577),(3.042204,-1.2375655)]
λ>
Next, we can use that to write a function that provides an unlimited supply of updated position sets, again using recursion:
randomPointSets :: StdGen -> [Point] -> [[Point]]
randomPointSets gen0 origins =
let (pts1, gen1) = nextRandoms gen0 origins
in pts1 : (randomPointSets gen1 pts1)
Note that the pts1 : code bit in the last line is what “remembers” the previous position set, so to speak.
Instead of recursion, we could also have uses here the unfoldr :: (s -> Maybe (a, s)) -> s -> [a] library function, with s being the state of the generator.
Test program:
printAsLines :: Show α => [α] -> IO ()
printAsLines xs = mapM_ (putStrLn . show) xs
main = do
let seed = 4243
gen0 = mkStdGen seed
origins = [(1,2),(2,5),(4,7),(3,3)] :: [Point]
allPointSets = randomPointSets gen0 origins -- unlimited supply
somePointSets = take 5 allPointSets
putStrLn $ show origins
printAsLines somePointSets
Test program output:
$ q66762139.x
[(1.0,2.0),(2.0,5.0),(4.0,7.0),(3.0,3.0)]
[(3.8172607,-0.54611135),(4.0293427,6.095909),(-0.6763873,6.4596577),(3.042204,-1.2375655)]
[(7.1006527,1.5599048),(8.395166,3.1540604),(-2.486746,9.749242),(2.2286167,-1.868607)]
[(11.424954,-0.13780117),(6.5587683,2.593749),(-2.8453062,7.9606133),(2.1931071,-4.915463)]
[(13.615167,-1.636116),(10.159166,1.8223867),(1.733639,6.011344),(6.2104306,-3.4672318)]
[(16.450119,-2.8003001),(12.556836,5.0577183),(2.8106451e-2,4.4519606),(2.2063198,-0.5508909)]
$
Side note:
Here, we have used manual chaining of the generator state. For more complex usage of pseudo-random numbers, this technique can become too cumbersome. If so, more powerful monadic notations from the Control.Monad.Random package can be used instead.
Related
I have random number generator
rand :: Int -> Int -> IO Int
rand low high = getStdRandom (randomR (low,high))
and a helper function to remove an element from a list
removeItem _ [] = []
removeItem x (y:ys) | x == y = removeItem x ys
| otherwise = y : removeItem x ys
I want to shuffle a given list by randomly picking an item from the list, removing it and adding it to the front of the list. I tried
shuffleList :: [a] -> IO [a]
shuffleList [] = []
shuffleList l = do
y <- rand 0 (length l)
return( y:(shuffleList (removeItem y l) ) )
But can't get it to work. I get
hw05.hs:25:33: error:
* Couldn't match expected type `[Int]' with actual type `IO [Int]'
* In the second argument of `(:)', namely
....
Any idea ?
Thanks!
Since shuffleList :: [a] -> IO [a], we have shuffleList (xs :: [a]) :: IO [a].
Obviously, we can't cons (:) :: a -> [a] -> [a] an a element onto an IO [a] value, but instead we want to cons it onto the list [a], the computation of which that IO [a] value describes:
do
y <- rand 0 (length l)
-- return ( y : (shuffleList (removeItem y l) ) )
shuffled <- shuffleList (removeItem y l)
return y : shuffled
In do notation, values to the right of <- have types M a, M b, etc., for some monad M (here, IO), and values to the left of <- have the corresponding types a, b, etc..
The x :: a in x <- mx gets bound to the pure value of type a produced / computed by the M-type computation which the value mx :: M a denotes, when that computation is actually performed, as a part of the combined computation represented by the whole do block, when that combined computation is performed as a whole.
And if e.g. the next line in that do block is y <- foo x, it means that a pure function foo :: a -> M b is applied to x and the result is calculated which is a value of type M b, denoting an M-type computation which then runs and produces / computes a pure value of type b to which the name y is then bound.
The essence of Monad is thus this slicing of the pure inside / between the (potentially) impure, it is these two timelines going on of the pure calculations and the potentially impure computations, with the pure world safely separated and isolated from the impurities of the real world. Or seen from the other side, the pure code being run by the real impure code interacting with the real world (in case M is IO). Which is what computer programs must do, after all.
Your removeItem is wrong. You should pick and remove items positionally, i.e. by index, not by value; and in any case not remove more than one item after having picked one item from the list.
The y in y <- rand 0 (length l) is indeed an index. Treat it as such. Rename it to i, too, as a simple mnemonic.
Generally, with Haskell it works better to maximize the amount of functional code at the expense of non-functional (IO or randomness-related) code.
In your situation, your “maximum” functional component is not removeItem but rather a version of shuffleList that takes the input list and (as mentioned by Will Ness) a deterministic integer position. List function splitAt :: Int -> [a] -> ([a], [a]) can come handy here. Like this:
funcShuffleList :: Int -> [a] -> [a]
funcShuffleList _ [] = []
funcShuffleList pos ls =
if (pos <=0) || (length(take (pos+1) ls) < (pos+1))
then ls -- pos is zero or out of bounds, so leave list unchanged
else let (left,right) = splitAt pos ls
in (head right) : (left ++ (tail right))
Testing:
λ>
λ> funcShuffleList 4 [0,1,2,3,4,5,6,7,8,9]
[4,0,1,2,3,5,6,7,8,9]
λ>
λ> funcShuffleList 5 "#ABCDEFGH"
"E#ABCDFGH"
λ>
Once you've got this, you can introduce randomness concerns in simpler fashion. And you do not need to involve IO explicitely, as any randomness-friendly monad will do:
shuffleList :: MonadRandom mr => [a] -> mr [a]
shuffleList [] = return []
shuffleList ls =
do
let maxPos = (length ls) - 1
pos <- getRandomR (0, maxPos)
return (funcShuffleList pos ls)
... IO being just one instance of MonadRandom.
You can run the code using the default IO-hosted random number generator:
main = do
let inpList = [0,1,2,3,4,5,6,7,8]::[Integer]
putStrLn $ "inpList = " ++ (show inpList)
-- mr automatically instantiated to IO:
outList1 <- shuffleList inpList
putStrLn $ "outList1 = " ++ (show outList1)
outList2 <- shuffleList outList1
putStrLn $ "outList2 = " ++ (show outList2)
Program output:
$ pickShuffle
inpList = [0,1,2,3,4,5,6,7,8]
outList1 = [6,0,1,2,3,4,5,7,8]
outList2 = [8,6,0,1,2,3,4,5,7]
$
$ pickShuffle
inpList = [0,1,2,3,4,5,6,7,8]
outList1 = [4,0,1,2,3,5,6,7,8]
outList2 = [2,4,0,1,3,5,6,7,8]
$
The output is not reproducible here, because the default generator is seeded by its launch time in nanoseconds.
If what you need is a full random permutation, you could have a look here and there - Knuth a.k.a. Fisher-Yates algorithm.
i'm trying to write a function that for n gives matrix n*n with unique rows and columns (latin square).
I got function that gives my list of strings "1" .. "2" .. "n"
numSymbol:: Int -> [String]
I tried to generate all permutations of this, and them all n-length tuples of permutations, and them check if it is unique in row / columns. But complexity (n!)^2 works perfect for 2 and 3, but with n > 3 it takes forever. It is possible to build latin square from permutations directly, for example from
permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]]
get
[[["1","2","3",],["2","1","3"],["3","1","2"]] , ....]
without generating list like [["1",...],["1",...],...], when we know first element disqualify it ?
Note: since we can easily take a Latin square that's been filled with numbers from 1 to n and re-label it with anything we want, we can write code that uses integer symbols without giving anything away, so let's stick with that.
Anyway, the stateful backtracking/nondeterministic monad:
type StateList s = StateT s []
is helpful for this sort of problem.
Here's the idea. We know that every symbol s is going to appear exactly once in each row r, so we can represent this with an urn of all possible ordered pairs (r,s):
my_rs_urn = [(r,s) | r <- [1..n], s <- [1..n]]
Similarly, as every symbol s appears exactly once in each column c, we can use a second urn:
my_cs_urn = [(c,s) | c <- [1..n], s <- [1..n]]
Creating a Latin square is matter of filling in each position (r,c) with a symbol s by removing matching balls (r,s) and (c,s) (i.e., removing two balls, one from each urn) so that every ball is used exactly once. Our state will be the content of the urns.
We need backtracking because we might reach a point where for a particular position (r,c), there is no s such that (r,s) and (c,s) are both still available in their respective urns. Also, a pleasant side-effect of list-based backtracking/nondeterminism is that it'll generate all possible Latin squares, not just the first one it finds.
Given this, our state will look like:
type Urn = [(Int,Int)]
data S = S
{ size :: Int
, rs :: Urn
, cs :: Urn }
I've included the size in the state for convenience. It won't ever be modified, so it actually ought to be in a Reader instead, but this is simpler.
We'll represent a square by a list of cell contents in row-major order (i.e., the symbols in positions [(1,1),(1,2),...,(1,n),(2,1),...,(n,n)]):
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
Now, the monadic action to generate latin squares will look like this:
type M = StateT S []
latin :: M Square
latin = do
n <- gets size
-- for each position (r,c), get a valid symbol `s`
cells <- forM (pairs n) (\(r,c) -> getS r c)
return $ Square n cells
pairs :: Int -> [(Int,Int)]
pairs n = -- same as [(x,y) | x <- [1..n], y <- [1..n]]
(,) <$> [1..n] <*> [1..n]
The worker function getS picks an s so that (r,s) and (c,s) are available in the respective urns, removing those pairs from the urns as a side effect. Note that getS is written non-deterministically, so it'll try every possible way of picking an s and associated balls from the urns:
getS :: Int -> Int -> M Int
getS r c = do
-- try each possible `s` in the row
s <- pickSFromRow r
-- can we put `s` in this column?
pickCS c s
-- if so, `s` is good
return s
Most of the work is done by the helpers pickSFromRow and pickCS. The first, pickSFromRow picks an s from the given row:
pickSFromRow :: Int -> M Int
pickSFromRow r = do
balls <- gets rs
-- "lift" here non-determinstically picks balls
((r',s), rest) <- lift $ choices balls
-- only consider balls in matching row
guard $ r == r'
-- remove the ball
modify (\st -> st { rs = rest })
-- return the candidate "s"
return s
It uses a choices helper which generates every possible way of pulling one element out of a list:
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
The second, pickCS checks if (c,s) is available in the cs urn, and removes it if it is:
pickCS :: Int -> Int -> M ()
pickCS c s = do
balls <- gets cs
-- only continue if the required ball is available
guard $ (c,s) `elem` balls
-- remove the ball
modify (\st -> st { cs = delete (c,s) balls })
With an appropriate driver for our monad:
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n p p)
where p = pairs n
this can generate all 12 Latin square of size 3:
λ> runM 3 latin
[Square 3 [1,2,3,2,3,1,3,1,2],Square 3 [1,2,3,3,1,2,2,3,1],...]
or the 576 Latin squares of size 4:
λ> length $ runM 4 latin
576
Compiled with -O2, it's fast enough to enumerate all 161280 squares of size 5 in a couple seconds:
main :: IO ()
main = print $ length $ runM 5 latin
The list-based urn representation above isn't very efficient. On the other hand, because the lengths of the lists are pretty small, there's not that much to be gained by finding more efficient representations.
Nonetheless, here's complete code that uses efficient Map/Set representations tailored to the way the rs and cs urns are used. Compiled with -O2, it runs in constant space. For n=6, it can process about 100000 Latin squares per second, but that still means it'll need to run for a few hours to enumerate all 800 million of them.
{-# OPTIONS_GHC -Wall #-}
module LatinAll where
import Control.Monad.State
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!))
import qualified Data.Map as Map
data S = S
{ size :: Int
, rs :: Map Int [Int]
, cs :: Set (Int, Int) }
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
type M = StateT S []
-- Get Latin squares
latin :: M Square
latin = do
n <- gets size
cells <- forM (pairs n) (\(r,c) -> getS r c)
return $ Square n cells
-- All locations in row-major order [(1,1),(1,2)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [1..n] <*> [1..n]
-- Get a valid `s` for position `(r,c)`.
getS :: Int -> Int -> M Int
getS r c = do
s <- pickSFromRow r
pickCS c s
return s
-- Get an available `s` in row `r` from the `rs` urn.
pickSFromRow :: Int -> M Int
pickSFromRow r = do
urn <- gets rs
(s, rest) <- lift $ choices (urn ! r)
modify (\st -> st { rs = Map.insert r rest urn })
return s
-- Remove `(c,s)` from the `cs` urn.
pickCS :: Int -> Int -> M ()
pickCS c s = do
balls <- gets cs
guard $ (c,s) `Set.member` balls
modify (\st -> st { cs = Set.delete (c,s) balls })
-- Return all ways of removing one element from list.
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
where rs0 = Map.fromAscList $ zip [1..n] (repeat [1..n])
cs0 = Set.fromAscList $ pairs n
main :: IO ()
main = do
print $ runM 3 latin
print $ length (runM 4 latin)
print $ length (runM 5 latin)
Somewhat remarkably, modifying the program to produce only reduced Latin squares (i.e., with symbols [1..n] in order in both the first row and the first column) requires changing only two functions:
-- All locations in row-major order, skipping first row and column
-- i.e., [(2,2),(2,3)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [2..n] <*> [2..n]
-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
where -- skip balls [(1,1)..(n,n)] for first row
rs0 = Map.fromAscList $ map (\r -> (r, skip r)) [2..n]
-- skip balls [(1,1)..(n,n)] for first column
cs0 = Set.fromAscList $ [(c,s) | c <- [2..n], s <- skip c]
skip i = [1..(i-1)]++[(i+1)..n]
With these modifications, the resulting Square will include symbols in row-major order but skipping the first row and column. For example:
λ> runM 3 latin
[Square 3 [3,1,1,2]]
means:
1 2 3 fill in question marks 1 2 3
2 ? ? =====================> 2 3 1
3 ? ? in row-major order 3 1 2
This is fast enough to enumerate all 16,942,080 reduced Latin squares of size 7 in a few minutes:
$ stack ghc -- -O2 -main-is LatinReduced LatinReduced.hs && time ./LatinReduced
[1 of 1] Compiling LatinReduced ( LatinReduced.hs, LatinReduced.o )
Linking LatinReduced ...
16942080
real 3m9.342s
user 3m8.494s
sys 0m0.848s
As part of my Haskell journey, I am implementing a raytracer and I need to be able to draw sequences of random numbers at several places in the code. Typically I would like to be able to get say 64 samples for each pixels and pixels are computed in parallel.
I was looking at the state monad to achieve that and I was guided by this answer Sampling sequences of random numbers in Haskell but the code I wrote does not terminate and it's memory consumption explodes.
Here is the abstracted part of the code:
I was hopping to be able to call sampleUniform several time in the code to get new lists of random numbers but if I do runhaskell test.hs, it outputs the first character of the lis [ and then it is stuck in an apparently infinite loop.
module Main (main
, computeArray) where
import Control.Monad
import Control.Monad.State (State, evalState, get, put)
import System.Random (StdGen, mkStdGen, random)
import Control.Applicative ((<$>))
type Rnd a = State StdGen a
runRandom :: Rnd a -> Int -> a
runRandom action seed = evalState action $ mkStdGen seed
rand :: Rnd Double
rand = do
gen <- get
let (r, gen') = random gen
put gen'
return r
{- Uniform distributions -}
uniform01 :: Rnd [Double]
uniform01 = mapM (\_ -> rand) $ repeat ()
{- Get n samples uniformly distributed between 0 and 1 -}
sampleUniform :: Int -> Rnd [Double]
sampleUniform n = liftM (take n) uniform01
computeArray :: Rnd [Bool]
computeArray = do
samples1 <- sampleUniform 10
samples2 <- sampleUniform 10
let dat = zip samples1 samples2
return $ uncurry (<) <$> dat
main :: IO ()
main = do
let seed = 48
let res = runRandom computeArray seed
putStrLn $ show res
uniform01 threads your state through an infinite number of computations, which means that although it produces its result lazily, there is no hope of retrieving a final state at the end to use for the next sampling. liftM (take n) only affects the final value, not the state effects used to compute it. Therefore as written, you can only use uniform01/sampleUniform once.
Instead you can thread the state through only as many rand actions as you use, e.g. with
sampleUniform n = mapM (\_ -> rand) $ replicate n ()
or simpler
sampleUniform n = sequence $ replicate n rand
EDIT: Updated to include entire code.
I'm pretty new to Haskell, and am having an issue with a program I've written to do some entropy calculations for a course assignment (the assignment is the calculations, the use of Haskell is a choice, so I'm not asking for someone to do my homework for me, it would have taken me a trivial amount of time and effort to do this in Python). The code takes a 1D array:
--- first input (length 2):
--- 0,0 0,1 1,0 1,1
--- [.48, .02, .02, .48]
--- or:
--- 0 1
--- .48 .02 0
---
--- .02 .48 1
I then have defined a couple of general functions:
log2 :: Float -> Float
log2 x =
logBase 2 x
entropy :: [Float] -> Float
entropy probArray =
sum(map (\i -> (i * (log2 (1/i)))) probArray)
As well as functions for each specific calculation:
-- calculate joint entropy
jointEntropy :: [Float] -> Float
jointEntropy probArray =
entropy probArray
-- calculate entropy of X
splitByCol :: Int -> [Float] -> [[Float]]
splitByCol length probArray =
[(take length probArray)] ++ (splitByCol length (drop length probArray))
xEntropy :: Int -> [Float] -> Float
xEntropy length probArray =
entropy (map sum (splitByCol length probArray))
-- calculate entropy of Y
ithElements :: Int -> Int -> [Float] -> [Float]
ithElements level length matrixArray =
let indexArray = zip [0..(length^2 - 1)] matrixArray
in [snd x | x <- indexArray, fst x `mod` length == level]
splitByRow :: Int -> Int -> [[Float]] -> [[Float]]
splitByRow level length lists =
if level == length
then
tail lists -- return list sans full matrix array which was being carried at the front
else
splitByRow (level+1) length (lists ++ [(ithElements level length (lists !! 0))])
yEntropy :: Int -> [Float] -> Float
yEntropy length probArray =
entropy (map sum (splitByRow 0 length [probArray]))
--calculate mutual information
mutualInfo :: Float -> Float -> Float
mutualInfo xEnt yEnt =
xEnt - yEnt
-- calculate conditional of X given Y - (X|Y)
xCond :: Float -> Float -> Float
xCond xEnt mInfo =
xEnt - mInfo
-- calculate conditional of Y given X - (Y|X)
yCond :: Float -> Float -> Float
yCond yEnt mInfo =
yEnt - mInfo
These are then all chained together to return an array with each of the calculations I've wanted to perform:
-- caller functions -> resArray ends up looking like [H(X,Y), H(X), H(Y), I(X;Y), H(X|Y), H(Y|X)]
calcJointEnt :: [Float] -> [Float]
calcJointEnt probArray =
calcVarEnt probArray [(jointEntropy probArray)]
calcVarEnt :: [Float] -> [Float] -> [Float]
calcVarEnt probArray resArray =
let len = floor (sqrt (fromIntegral (length probArray)))
in calcMutual probArray (resArray ++ [(xEntropy len probArray), (yEntropy len probArray)])
calcMutual :: [Float] -> [Float] -> [Float]
calcMutual probArray resArray =
calcCond probArray (resArray ++ [(mutualInfo (resArray !! 1) (resArray !! 2))])
calcCond :: [Float] -> [Float] -> [Float]
calcCond probArray resArray =
resArray ++ [(xCond (resArray !! 1) (resArray !! 3)), (yCond (resArray !! 2) (resArray !! 3))]
And so on...I then have some functions to format a print string, and a main function to bring it all together:
-- prepare printout
statString :: (String, String) -> String
statString t =
(fst t) ++ ": " ++ (snd t)
printOut :: [Float] -> String
printOut resArray =
let statArray = zip ["H(X,Y)", "H(X)", "H(Y)", "H(X;Y)", "H(X|Y)", "H(Y|X)"] (map show resArray)
in "results:\n\t" ++ intercalate "\n\t" (map statString statArray) ++ "\n\n---\n"
-- main
main :: IO()
main =
let inputs = [[0.48, 0.02, 0.02, 0.48], [0.31, 0.02, 0.00, 0.02, 0.32, 0.02, 0.00, 0.02, 0.29]]
in putStrLn (intercalate "" (map printOut (map calcJointEnt inputs)))
So I'm sure there are better ways to do a lot of this, but it seems to me from my minimal haskell experience and my slightly more expansive but still limited functional-esqe style programming experience that it should work.
My problem is that when I compile and run, I get this output:
bash-4.2$ ./noise
results:
H(X,Y): 1.2422923
noise: out of memory (requested 1048576 bytes)
With a large amount of time between the one result being printed out and the memory error message. When I pop it open in the ghci debugger (which I'm using for the first time), if I attempt to force, say, resArray in the printOut function, it does the same, and when I try to sequentially unpack resArray at the lowest level of the chaining functions:
calcCond :: [Float] -> [Float] -> [Float]
calcCond probArray resArray =
resArray ++ [(xCond (resArray !! 1) (resArray !! 3)), (yCond (resArray !! 2) (resArray !! 3))]
I get the following:
[noise.hs:101:3-96] *Main> seq _t1 ()
()
[noise.hs:101:3-96] *Main> :print resArray
resArray = (_t2::Float) : (_t3::[Float])
[noise.hs:101:3-96] *Main> seq _t2 ()
()
[noise.hs:101:3-96] *Main> :print resArray
resArray = 1.2422923 : (_t4::[Float])
[noise.hs:101:3-96] *Main> seq _t3 ()
()
[noise.hs:101:3-96] *Main> :print resArray
resArray = 1.2422923 : (_t5::Float) : (_t6::[Float])
[noise.hs:101:3-96] *Main> seq _t5 ()
^C^C^C^C^CInterrupted.
[noise.hs:101:3-96] *Main>
I looked into the RTS debugging tool, which seemed to be the recommended tool for popping open the hood for things like this in similarly posed questions on the site, but when I ran it with +RTS -xc nothing happened. I assume it's because RTS seems to require it to actually throw an exception, as opposed to the OS stepping in?
I think the major problem for myself coming from an imperative background is that the notion that the program can reach the IO statements with some sort of infinite looping procedure still going on somewhere up the logic is an alien concept. Of course, I could be completely incorrect that that's what is going on, but it's what it seems like to me. Any help you all can give (not just on this code, but also just in general with my approach to Haskell) would be greatly appreciated.
Since H(X) is never printed it makes sense to have a look where it is calculated, i.e. xEntropy. xEntropy calls splitByCol which has an obvious bug. It returns an infinite list! That means entropy never terminates, because it attempts to call sum on an infinite list.
I am attempting to implement the following algorithm, as detailed here.
Start with a flat terrain (initialize all height values to zero).
Pick a random point on or near the terrain, and a random radius
between some predetermined minimum and maximum. Carefully choosing
this min and max will make a terrain rough and rocky or smooth and
rolling.
Raise a hill on the terrain centered at the point, having the given
radius.
Go back to step 2, and repeat as many times as necessary. The number
of iterations chosen will affect the appearance of the terrain.
However, I start to struggle once I get to the point where I have to select a random point on the terrain. This random point is wrapped in an IO monad, which is then passed up my chain of functions.
Can I cut the IO off at a certain point and, if so, how do I find that point?
The following is my (broken) code. I would appreciate any suggestions on improving it / stopping the randomness from infecting everything.
type Point = (GLfloat, GLfloat, GLfloat)
type Terrain = [Point]
flatTerrain :: Double -> Double -> Double -> Double -> Terrain
flatTerrain width length height spacing =
[(realToFrac x, realToFrac y, realToFrac z)
| x <- [-width,-1+spacing..width], y <- [height], z <- [-length,-1+spacing..length]]
hill :: Terrain -> Terrain
hill terrain = hill' terrain 100
where hill' terrain 0 = terrain
hill' terrain iterations = do
raised <- raise terrain
hill' (raise terrain) (iterations - 1)
raise terrain = do
point <- pick terrain
map (raisePoint 0.1 point) terrain
raisePoint r (cx,cy,cz) (px,py,pz) =
(px, r^2 - ((cx - px)^2 + (cz - pz)^2), pz)
pick :: [a] -> IO a
pick xs = randomRIO (0, (length xs - 1)) >>= return . (xs !!)
The algorithm says that you need to iterate and in each iteration select a random number and update the terrain which can be viewed as generate a list of random points and use this list to update the terrain i.e iteration to generate random numbers == list of random numbers.
So you can do something like:
selectRandomPoints :: [Points] -> Int -> IO [Points] -- generate Int times random points
updateTerrain :: Terrain -> [Points] -> Terrain
-- somewhere in IO
do
pts <- selectRandomPoints allPts iterationCount
let newTerrain = updateTerrain t pts
One of the most useful features of haskell is to know a function is deterministic just based on its type - it makes testing much easier. For this reason, I would base my design on limiting randomness as much as possible, and wrapping the core non random functions with a random variant. This is easily done with the MonadRandom type class, which is the best way of writing code in haskell that requires random values.
For fun, I wrote a console version of that hill generator. It is pretty basic, with a lot of hard coded constants. However, it does provide a pretty cool ascii terrain generator :)
Note with my solution all of the calculations are isolated in pure, non random functions. This could then be tested easily, as the result is deterministic. As little as possible occurs in the IO monad.
import Control.Monad
import Control.Monad.Random
import Data.List
import Data.Function (on)
type Point = (Double, Double, Double)
type Terrain = [Point]
-- Non random code
flatTerrain :: Double -> Double -> Double -> Double -> Terrain
flatTerrain width length height spacing = [(realToFrac x, realToFrac y, realToFrac z)
| x <- [-width,-width+spacing..width], y <- [height], z <- [-length,-length+spacing..length]]
-- simple terrain displayer, uses ascii to render the area.
-- assumes the terrain points are all separated by the same amount
showTerrain :: Terrain -> String
showTerrain terrain = unlines $ map (concat . map showPoint) pointsByZ where
pointsByZ = groupBy ((==) `on` getZ) $ sortBy (compare `on` getZ) terrain
getZ (_, _, z) = z
getY (_, y, _) = y
largest = getY $ maximumBy (compare `on` getY) terrain
smallest = getY $ minimumBy (compare `on` getY) terrain
atPC percent = (largest - smallest) * percent + smallest
showPoint (_, y, _)
| y < atPC (1/5) = " "
| y < atPC (2/5) = "."
| y < atPC (3/5) = "*"
| y < atPC (4/5) = "^"
| otherwise = "#"
addHill :: Double -- Radius of hill
-> Point -- Position of hill
-> Terrain -> Terrain
addHill radius point = map (raisePoint radius point) where
raisePoint :: Double -> Point -> Point -> Point
-- I had to add max py here, otherwise new hills destroyed the
-- old hills with negative values.
raisePoint r (cx,cy,cz) (px,py,pz) = (px, max py (r^2 - ((cx - px)^2 + (cz - pz)^2)), pz)
-- Some random variants. IO is an instance of MonadRandom, so these function can be run in IO. They
-- can also be run in any other monad that has a MonadRandom instance, so they are pretty flexible.
-- creates a random point. Note that the ranges are hardcoded - an improvement would
-- be to be able to specify them, either through parameters, or through reading from a Reader
-- monad or similar
randomPoint :: (MonadRandom m) => m Point
randomPoint = do
x <- getRandomR (-30, 30)
y <- getRandomR (0,10)
z <- getRandomR (-30, 30)
return (x, y, z)
addRandomHill :: (MonadRandom m) => Terrain -> m Terrain
addRandomHill terrain = do
radius <- getRandomR (0, 8) -- hardcoded again
position <- randomPoint
return $ addHill radius position terrain
-- Add many random hills to the Terrain
addRandomHills :: (MonadRandom m) => Int -> Terrain -> m Terrain
addRandomHills count = foldr (>=>) return $ replicate count addRandomHill
-- testing code
test hillCount = do
let terrain = flatTerrain 30 30 0 2
withHills <- addRandomHills hillCount terrain
-- let oneHill = addHill 8 (0, 3, 0) terrain
-- putStrLn $ showTerrain oneHill
putStrLn $ showTerrain withHills
main = test 200
Example output:
... .. ..*. .***^^^***.
... ... .***. .***^^^*^^*.
... .. .*^**......*^*^^^^.
. .***.***. ..*^^^*.
....*^^***^*. .^##^*.
..*.*^^^*****. .^###^..*
.**^^^^.***... .*^#^*.**
.***^##^**..*^^*.*****..**
....***^^##^*.*^##^****. ..
.......*^###^.*###^****.
.*********^###^**^##^***....
*^^^*^##^^^^###^.^^^*. .****..
*^^^^####*^####^..**. .******.
*^^^*####**^###*. .. .*******
*^#^^^##^***^^*. ...........***
*^^^**^^*..*... ..*******...***
.***..*^^*... ..*^^#^^^*......
...*^##^**. .*^^#####*.
.*^##^**....**^^####*. .***
.. ..*^^^*...*...**^^###^* *^#^
..****^^*. .... ...**###^*.^###
..*******.**. ..**^^^#^^..^###
.*****..*^^* ..**^##^**...*^##
.^^^^....*^^*..*^^^##^* ..**^^^
*###^*. .*^**..^###^^^*...*****
^####*.*..*^^*.^###^**.....*..
*###^**^**^^^*.*###^. .. .
.^^^***^^^^#^*.**^^**.
.....***^##^**^^^*^^*.
.*^^##^*^##^^^^^.
.*^^^^*.^##^*^^*.
Nope, you can't escape IO. Perhaps you can do all your randomness up front and rewrite your functions to take that randomness as a parameter; if not, you can use MonadRandom or similar to track a random seed or just put everything in IO.