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.
Related
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.
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.
Again I'm requesting comments about how a given design should be implemented in Haskell.
Thanks in advance to everyone providing helpful comments. Also I hope this could be an aid to other Haskell novices like me, having a practical sample code.
This time, we have a polymorphic function doSampling (in module Samples) that takes a generic function f and
a list of reals (indexes) and returns a Samples (indexes, values=f(indexes)). We want implement doSampling only once, as it doesn't matter if is f is a Polynomial or a Sinus. For that,
we have introduced an interface Function, and have Polynomial and Sinus types implement it.
The following is the design being implemented:
Edit 1:
There is a debate on the Function interface (class in Haskell). It has been suggested it is not actually necessary, as doSampling may take a "nude" function (Double -> Double) instead.
But, how to do it, if you need some extra state within the nude function (coeffs for a polynomial, amp+freq+phase for a sinus?
Edit 2:
Very good answers by kosmikus and by Chris Taylor. Thanks.
A key idea in both: have
doSampling :: (Double -> Double) -> [Double] -> Samples
This is: it takes a function (Double -> Double) (instead of Function) and list and returns samples.
My intention was to keep the state of Polynomials and Sinuses. That is not regarded in Chris answer, but it is in kosmikus'. On the other hand, the weak point in kosmikus version could be how to extend its Function definition if you don't have access to the source code.
I would also point out:
Chris' idea of encapsulating a polynomial or a sinus into a function (Double -> Double) by means of a factory function mkPolynomial or mkSinus that generates (using currying?) the desired function taking the apropriate parameters. (Although you can't consult the parameters later).
kosmikous' idea of using value to transform (also using currying?) a Function into a (Double -> Double)
Both answers are worth reading as they have other little Haskell tricks to reduce and simplify code.
In sum
Chris answers does not support keeping the state of a Polynomial or of a Sinus
kosmikus answers is not extensible: adding new type of functions (Cosinus ...)
my answer (being verbose) does overcome the previous downsides, and it would allow (this not necessary for the problem) impose Function types to have more associated-functions apart of value (in the sense of how an java-interfaces work).
My own approach
main (usage)
import Polynomial
import Sinus
import Function
import Samples
-- ...............................................................
p1 = Polynomial [1, 0, 0.5] -- p(x) = 1 + 0.5x^2
s1 = Sinus 2 0.5 3 -- f(x) = 2 sin(0.5x + 3)
-- ...............................................................
-- sample p1 from 0 to 5
m1 = doSampling p1 [0, 0.5 .. 5]
m2 = doSampling s1 [0, 0.5 .. 5]
-- ...............................................................
-- main
-- ...............................................................
main = do
putStrLn "Hello"
print $ value p1 2
print $ value s1 (pi/2)
print $ pairs m1
print $ pairs m2
Function
module Function where
-- ...............................................................
-- "class type" : the types belonging to this family of types
-- must implement the following functions:
-- + value : takes a function and a real and returns a real
-- ...............................................................
class Function f where
value :: f -> Double -> Double
-- f is a type variable, this is:
-- f is a type of the Function "family" not an actual function
Samples
module Samples where
import Function
-- ...............................................................
-- Samples: new data type
-- This is the constructor and says it requieres
-- two list, one for the indexes (xs values) and another
-- for the values ( ys = f (xs) )
-- this constructor should not be used, instead use
-- the "factory" function: new_Samples that performs some checks
-- ...............................................................
data Samples = Samples { indexes :: [Double] , values :: [Double] }
deriving (Show)
-- ...............................................................
-- constructor: it checks lists are equal size, and indexes are sorted
new_Samples :: [Double] -> [Double] -> Samples
new_Samples ind val
| (length ind) /= (length val) = samplesVoid
| not $ isSorted ind = samplesVoid
| otherwise = Samples ind val
-- ...............................................................
-- sample a funcion
-- it takes a funcion f and a list of indexes and returns
-- a Samples calculating the values array as f(indexes)
doSampling :: (Function f) => f -> [Double] -> Samples
doSampling f ind = new_Samples ind vals
where
vals = [ value f x | x <- ind ]
-- ...............................................................
-- used as "error" in the construction
samplesVoid = Samples [] []
-- ...............................................................
size :: Samples -> Int
size samples = length (indexes samples)
-- ...............................................................
-- utility function to get a pair (index,value) out of a Samples
pairs :: Samples -> [(Double, Double)]
pairs samples = pairs' (indexes samples) (values samples)
pairs' :: [Double] -> [Double] -> [(Double, Double)]
pairs' [] [] = []
pairs' [i] [v] = [(i,v)]
pairs' (i:is) (v:vs) = (i,v) : pairs' is vs
-- ...............................................................
-- to check whether a list is sorted (<)
isSorted :: (Ord t) => [t] -> Bool
isSorted [] = True
isSorted [e] = True
isSorted (e1:(e2:tail))
| e1 < e2 = isSorted (e2:tail)
| otherwise = False
Sinus
module Sinus where
-- ...............................................................
import Function
-- ...............................................................
-- Sinus: new data type
-- This is the constructor and says it requieres
-- a three reals
-- ...............................................................
data Sinus = Sinus { amplitude :: Double, frequency :: Double, phase :: Double }
deriving (Show)
-- ...............................................................
-- we say that a Sinus is a Function (member of the class Function)
-- and then, how value is implemented
instance Function Sinus where
value s x = (amplitude s) * sin ( (frequency s)*x + (phase s))
Polynomial
module Polynomial where
-- ...............................................................
import Function
-- ...............................................................
-- Polynomial: new data type
-- This is the constructor and says it requieres
-- a list of coefficients
-- ...............................................................
data Polynomial = Polynomial { coeffs :: [Double] }
deriving (Show)
-- ...............................................................
degree :: Polynomial -> Int
degree p = length (coeffs p) - 1
-- ...............................................................
-- we say that a Polynomial is a Function (member of the class Function)
-- and then, how value is implemented
instance Function Polynomial where
value p x = value' (coeffs p) x 1
-- list of coeffs -> x -> pw (power of x) -> Double
value' :: [Double] -> Double -> Double -> Double
value' (c:[]) _ pw = c * pw
value' (c:cs) x pw = (c * pw) + (value' cs x x*pw)
You certainly don't need the Function class. All this heavyweight class, instance, member variable fluff is one of the things that Haskell is designed to avoid. Pure functions can be much more flexible.
Here's a simple way of doing what you want.
type Sample = ([Double], [Double])
newSample xs vs
| isSorted xs && length xs == length vs = (indices, values)
| otherwise = ([], [])
pairs = uncurry zip
doSampling :: (Double -> Double) -> [Double] -> Sample
doSampling f xs = newSample xs (map f xs)
mkPolynomial :: [Double] -> (Double -> Double)
mkPolynomial coefs x = go coefs
where
go [] = 0
go (c:cs) = c + x * go cs
mkSinus :: Double -> Double -> Double -> (Double -> Double)
mkSinus amp freq phase x = amp * sin (freq * x + phase)
p1 = mkPolynomial [1, 0, 0.5] -- 1 + 0.5x^2
s1 = mkSinus 2 0.5 3 -- 2 sin(0.5x + 3)
m1 = doSampling p1 [0, 0.5 .. 5]
m2 = doSampling s1 [0, 0.5 .. 5]
main :: IO ()
main = do
print $ p1 2
print $ s1 (pi/2)
print $ pairs m1
print $ pairs m2
[Expanded my comment on request.]
I'd probably do this roughly as follows:
import Data.Functor
-- Use a datatype rather than a class. Yes, this makes it harder to
-- add new types of functions later, and in turn easier to define new
-- operations. ("expression problem")
data Function =
Sinus { amplitude :: Double, frequency :: Double, phase :: Double }
| Polynomial { coeffs :: [Double] }
deriving (Show)
-- Interpreting a Function as an actual function.
value :: Function -> (Double -> Double)
value (Sinus amp freq ph) x = amp * sin (freq * x + ph)
value (Polynomial cs) x = value' cs x
-- Rewrite value' to not require non-empty lists. This can also be
-- nicely written as a fold.
value' :: [Double] -> Double -> Double
value' [] _ = 0
value' (c:cs) x = c + x * value' cs x
data Samples = Samples { indexes :: [Double] , values :: [Double] }
deriving (Show)
-- Use Maybe to detect error conditions, instead of strange values
-- such as voidSamples.
newSamples :: [Double] -> [Double] -> Maybe Samples
newSamples ind val
| length ind /= length val = Nothing
| not $ isSorted ind = Nothing
| otherwise = Just (Samples ind val)
doSampling :: (Double -> Double) -> [Double] -> Maybe Samples
doSampling f ind = newSamples ind (map f ind)
isSorted :: (Ord t) => [t] -> Bool
isSorted [] = True
isSorted [e] = True
isSorted (e1:e2:es)
| e1 < e2 = isSorted (e2:es)
| otherwise = False
-- This is just zip.
pairs :: Samples -> [(Double, Double)]
pairs (Samples idxs vals) = zip idxs vals
p1 = Polynomial [1, 0, 0.5] -- p(x) = 1 + 0.5x^2
s1 = Sinus 2 0.5 3 -- f(x) = 2 sin(0.5x + 3)
m1 = doSampling (value p1) [0, 0.5 .. 5]
m2 = doSampling (value s1) [0, 0.5 .. 5]
-- The <$> maps over a Maybe.
main = do
putStrLn "Hello"
print $ value p1 2
print $ value s1 (pi/2)
print $ pairs <$> m1
print $ pairs <$> m2
I get the following error when trying to compile
$ ghc --make -O2 -Wall -fforce-recomp
[1 of 1] Compiling Main (
isPrimeSmart.hs, isPrimeSmart.o )
SpecConstr
Function `$wa{v s2we} [lid]'
has two call patterns, but the limit is 1
Use -fspec-constr-count=n to set the bound
Use -dppr-debug to see specialisations Linking isPrimeSmart
...
My code is:
{-# OPTIONS_GHC -O2 -optc-O2 #-}
import qualified Data.ByteString.Lazy.Char8 as StrL -- StrL is STRing Library
import Data.List
-- read in a file. First line tells how many cases. Each case is on a separate
-- line with the lower an upper bounds separated by a space. Print all primes
-- between the lower and upper bound. Separate results for each case with
-- a blank line.
main :: IO ()
main = do
let factors = takeWhile (<= (ceiling $ sqrt (1000000000::Double))) allPrimes
(l:ls) <- StrL.lines `fmap` StrL.getContents
let numCases = readInt l
let cases = (take numCases ls)
sequence_ $ intersperse (putStrLn "") $ map (doLine factors) cases
-- get and print all primes between the integers specified on a line.
doLine :: [Integer] -> StrL.ByteString -> IO ()
doLine factors l = mapM_ print $ primesForLine factors l
---------------------- pure code below this line ------------------------------
-- get all primes between the integers specified on a line.
primesForLine :: [Integer] -> StrL.ByteString -> [Integer]
primesForLine factors l = getPrimes factors range
where
range = rangeForLine l
-- Generate a list of numbers to check, store it in list, and then check them...
getPrimes :: [Integer] -> (Integer, Integer) -> [Integer]
getPrimes factors range = filter (isPrime factors) (getCandidates range)
-- generate list of candidate values based on upper and lower bound
getCandidates :: (Integer, Integer) -> [Integer]
getCandidates (propStart, propEnd) = list
where
list = if propStart < 3
then 2 : oddList
else oddList
oddList = [listStart, listStart + 2 .. propEnd]
listStart = if cleanStart `rem` 2 == 0
then cleanStart + 1
else cleanStart
cleanStart = if propStart < 3
then 3
else propStart
-- A line always has the lower and upper bound separated by a space.
rangeForLine :: StrL.ByteString -> (Integer, Integer)
rangeForLine caseLine = start `seq` end `seq` (start, end)
where
[start, end] = (map readInteger $ StrL.words caseLine)::[Integer]
-- read an Integer from a ByteString
readInteger :: StrL.ByteString -> Integer
readInteger x =
case StrL.readInteger x of Just (i,_) -> i
Nothing -> error "Unparsable Integer"
-- read an Int from a ByteString
readInt :: StrL.ByteString -> Int
readInt x =
case StrL.readInt x of Just (i,_) -> i
Nothing -> error "Unparsable Int"
-- generates all primes in a lazy way.
allPrimes :: [Integer]
allPrimes = ps (2:[3,5 .. ])
where
ps (np:candidates) = -- np stands for New Prime
np : ps (filter (\n -> n `rem` np /= 0) candidates)
ps [] = error "this can't happen but is shuts up the compiler"
-- Check to see if it is a prime by comparing against the factors.
isPrime :: [Integer] -> Integer -> Bool
isPrime factors val = all (\f -> val `rem` f /= 0) validFactors
where
validFactors = takeWhile (< ceil) factors
ceil = ((ceiling $ sqrt $ ((fromInteger val)::Double))) :: Integer
I have no idea how to fix this warning. How do I start? Do I compile to assembly and match the error up? What does the warning even mean?
These are just (annoying) warnings, indicating that GHC could do further specializations to your code if you really want to. Future versions of GHC will likely not emit this data by default, since there's nothing you can do about it anyway.
They are harmless, and are not errors. Don't worry about them.
To directly address the problem, you can use -w (suppress warnings) instead of -Wall.
E.g. in a file {-# OPTIONS_GHC -w #-} will disable warnings.
Alternately, increasing the specialization threshold will make the warning go away, e.g. -fspec-constr-count=16
So, in the following code, I am generating a wav file from notes and composed chords. I've got it working for single notes and chords of two notes, but for combinations of more than 2 notes, I run into problems because I am not normalizing the frequencies. I know what I need to do (divide the frequencies at each frame by the number of notes composing it) but not necessarily how to do it in an elegant manner (or, in any manner at all). What has to happen is, I need to somehow get the length of the list returned by notes'' up to buildChord, and then work out how to map a division by that number across the input to buildChord.
I'm really at a loss, here, so any input would be greatly appreciated.
import Data.WAVE
import Control.Applicative
import Data.Char (isDigit)
import Data.Function (on)
import Data.Int (Int32)
import Data.List (transpose, groupBy)
import Data.List.Split (splitOn, split, oneOf)
import System.IO (hGetContents, Handle, openFile, IOMode(..))
a4 :: Double
a4 = 440.0
frameRate :: Int
frameRate = 32000
noteLength :: Double
noteLength = 1
volume :: Int32
volume = maxBound `div` 2
buildChord :: [[Double]] -> WAVESamples
buildChord freqs = map ((:[]) . round . sum) $ transpose freqs
generateSoundWave :: Int -- | Samples Per Second
-> Double -- | Length of Sound in Seconds
-> Int32 -- | Volume
-> Double -- | Frequency
-> [Double]
generateSoundWave sPS len vol freq =
take (round $ len * fromIntegral sPS) $
map ((* fromIntegral vol) . sin)
[0.0, (freq * 2 * pi / fromIntegral sPS)..]
generateSoundWaves :: Int -- | Samples Per Second
-> Double -- | Length of Sound in Seconds
-> Int32 -- | Volume
-> [Double] -- | Frequency
-> [[Double]]
generateSoundWaves sPS len vol =
map (generateSoundWave sPS len vol)
noteToSine :: String -> WAVESamples
noteToSine chord =
buildChord $ generateSoundWaves frameRate noteLength volume freqs
where freqs = getFreqs $ notes chord
notes'' :: String -> [String]
notes'' = splitOn "/"
notes' :: [String] -> [[String]]
notes' = map (split (oneOf "1234567890"))
notes :: String -> [(String, Int)]
notes chord = concatMap pair $ notes' $ notes'' chord
where pair (x:y:ys) = (x, read y :: Int) : pair ys
pair _ = []
notesToSines :: String -> WAVESamples
notesToSines = concatMap noteToSine . splitOn " "
getFreq :: (String, Int) -> Double
getFreq (note, octave) =
if octave >= -1 && octave < 10 && n /= 12.0
then a4 * 2 ** ((o - 4.0) + ((n - 9.0) / 12.0))
else undefined
where o = fromIntegral octave :: Double
n = case note of
"B#" -> 0.0
"C" -> 0.0
"C#" -> 1.0
"Db" -> 1.0
"D" -> 2.0
"D#" -> 3.0
"Eb" -> 3.0
"E" -> 4.0
"Fb" -> 4.0
"E#" -> 5.0
"F" -> 5.0
"F#" -> 6.0
"Gb" -> 6.0
"G" -> 7.0
"G#" -> 8.0
"Ab" -> 8.0
"A" -> 9.0
"A#" -> 10.0
"Bb" -> 10.0
"B" -> 11.0
"Cb" -> 11.0
_ -> 12.0
getFreqs :: [(String, Int)] -> [Double]
getFreqs = map getFreq
header :: WAVEHeader
header = WAVEHeader 1 frameRate 32 Nothing
getFileName :: IO FilePath
getFileName = putStr "Enter the name of the file: " >> getLine
getChordsAndOctaves :: IO String
getChordsAndOctaves = getFileName >>= \n ->
openFile n ReadMode >>=
hGetContents
main :: IO ()
main = getChordsAndOctaves >>= \co ->
putWAVEFile "out.wav" (WAVE header $ notesToSines co)
The key problem was with the function:
buildChord :: [[Double]] -> WAVESamples
buildChord freqs = map ((:[]) . round . sum) $ transpose freqs
The result of transpose freqs was a list of sound volumes for a particular point in time for each note being played (eg [45.2, 20, -10]). The function (:[] . round . sum) firstly added them together (eg 55.2), rounds it (eg to 55), and wraps it in a list (eg [55]). map (:[] . round . sum) just did that for all the instances of time.
The problem is if you have many note playing at once, the sum results in a note that is too loud. What would be better is to take the average of the notes, rather than the sum. That means 10 notes playing at the same time wont be too loud. Surprisingly, there is no average function in the prelude. So we can either write our own average function, or just embed it in the function passed to map. I did the latter as it was less code:
buildChord :: [[Double]] -> WAVESamples
buildChord freqs = map (\chord -> [round $ sum chord / genericLength chord]) $ transpose freqs
I'm guessing from your questions that you are writing a music making program as a way to learn haskell. I have a few ideas that may make your code easier to debug, and more "haskell like".
Code in haskell is often written as a sequence of transformations from input to output. That buildChord function is a good example - firstly the input was transposed, then mapped over with a function that combined the multiple sound amplitudes. However, you could also structure your whole program in this style.
The purpose of the program seems to be: "read notes from a file in some format, then create a wav file from those notes read". The way I would solve that problem would be firstly to break that up into different pure transformations (ie using no input or output), and do the reading and writing as the final step.
I would firstly start by writing a sound wave to WAVE transformation. I would use the type:
data Sound = Sound { soundFreqs :: [Double]
, soundVolume :: Double
, soundLength :: Double
}
Then write the function:
soundsToWAVE :: Int -> [Sound] -> WAVE
soundsToWAVE samplesPerSec sounds = undefined -- TODO
Then I could write the functions writeSoundsToWavFile and testPlaySounds:
writeSoundsToWavFile :: String -> Int -> [Sound] -> IO ()
writeSoundsToWavFile fileN samplesPerSec sounds = putWAVEFile $ soundsToWAVE fileN samplesPerSec sounds
testPlaySounds :: [Sound] -> IO ()
testPlaySounds sounds = do
writeSoundsToWavFile "test.wav" 32000 sounds
system("afplay test.wav") -- use aplay on linux, don't know for windows
return ()
Once that is done, all the WAVE code is done - the rest of the code doesn't need to touch it. It may be a good idea to put that in its own module.
After that, I would write a transformation between music notes and Sounds. I would use the following types for notes:
data Note = A | B | C | D | E | F | G
data NoteAugment = None | Sharp | Flat
data MusicNote = MusicNote { note :: Note, noteAugment :: NoteAugment, noteOctave :: Int }
data Chord = Chord { notes :: [MusicNote], chordVolume :: Double }
Then write the function:
chordToSound :: Chord -> Sound
chordToSound = undefined -- TODO
You could then easily write the function musicNotesToWAVFile:
chordsToWAVFile fileName samplesPerSec notes = writeSoundsToWavFile 32000 fileName samplesPerSec (map chordToSound notes)
(the function testPlayChords can be done in the same way). You could also put this in a new module.
Finally I would write the transformation note string -> [Chord]. This would just need the function:
parseNoteFileText :: String -> [Chord]
parseNoteFileText noteText = undefined
The final program could then be wired up:
main = do
putStrLn "Enter the name of the file: "
fileN <- getLine
noteText <- readFile fileN
chordsToWAVFile (parseNoteFileText noteText)