I want to access the pixel data of what is being displayed to the window, but I have not had any luck finding such a function in gloss, nor by attempting to call OpenGL readPixels in a keyboard event callback. It looks like gloss renders a Picture to the window without exposing the rendered bitmap.
If this is hard to do in gloss, is there an alternative which has realtime high-level bitmap manipulation (translation, rotation, transparency)?
It turns out readPixels can be used in this case. I found this snippet while digging through #haskell chat logs:
-- save a screenshot to a handle as binary PPM
snapshotWith :: (BS.ByteString -> IO b) -> Position -> Size -> IO b
snapshotWith f p0 vp#(Size vw vh) = do
let fi q = fromIntegral q
p6 = "P6\n" ++ show vw ++ " " ++ show vh ++ " 255\n"
allocaBytes (fi (vw*vh*3)) $ \ptr -> do
readPixels p0 vp $ PixelData RGB UnsignedByte ptr
px <- BSI.create (fi $ vw * vh * 3) $ \d -> forM_ [0..vh-1] $ \y ->
BSI.memcpy
(d`plusPtr`fi(y*vw*3))
(ptr`plusPtr`fi ((vh-1-y)*vw*3))
(fi(vw*3))
f $ BS.pack (map (toEnum . fromEnum) p6) `BS.append` px
writeSnapshot :: FilePath -> Position -> Size -> IO ()
writeSnapshot f = snapshotWith (BS.writeFile f)
From https://gitorious.org/maximus/mandulia/source/58695617c322b0b37ec72f9a0bd3eed8308bf700:src/Snapshot.hs
Recently a new package gloss-export was released with the appropriate purpose:
Export gloss pictures as PNG, Bitmap, TGA, TIFF, Gif
I once had the same problem and couldn't find a good solution, so my answer probably won't be appropriate. My workaround was to use bmp package, deal with the BMP content manually (via ByteString manipulation), and then convert it to a glossy bitmap with bitmapOfBMP. For example, this was a function for blending a bitmap with a color:
recolor :: (Float, Float, Float) -> BMP -> BMP
recolor (rc, gc, bc) bmp#BMP {bmpRawImageData = raw} =
bmp {bmpRawImageData = B.pack $ process $ B.unpack raw} where
process (b:g:r:a:xs) = (mul b bc):(mul g gc):(mul r rc):a:process xs
process xs = xs
mul c cc = round $ cc * fromIntegral c
This was enough for me in that time, so I stopped finding a better solution. If you'll find something, please share.
Related
I am implementing a fractal image compression algorithm of binary images in Haskell. For this purpose i have to find to a given range block (a sub-image) the closest image in a so called domain pool, a list of lists of images. I am comparing images by calculating the sum square difference of both their pixel values.
I use the Haskell Image Processing (HIP) library for reading and writing images.
compress :: Image VS X Bit -> Int -> [(Int, Int)]
compress img blockSize = zip dIndices tIndices
where rImg = img
dImg = downsample2 rImg
rBlocks = (toBlocks rImg blockSize) :: [Image VS X Bit]
dBlocks = (toBlocks dImg blockSize) :: [Image VS X Bit]
dPool = (createDPool dBlocks) :: [[Image VS X Bit]]
distanceLists = map (\x -> (map.map) (distance x) dPool) rBlocks
dIndices = map (fst . getMinIndices) distanceLists
tIndices = map (snd . getMinIndices) distanceLists
distance :: Image VS X Bit -> Image VS X Bit-> Int
distance x y = sumSquareDifference (toBinList x) (toBinList y)
where toBinList = map (toNum . extractBitOfPixel) . concat . toLists
toLists :: MArray arr cs e => Image arr cs e -> [[Pixel cs e]]
toLists img = [[index img (i, j) | j <- [0..cols img -1]] | i <- [0.. rows img -1]]
extractBitOfPixel :: Pixel X Bit -> Bit
extractBitOfPixel (PixelX b) = b
sumSquareDifference :: [Int] -> [Int] -> Int
sumSquareDifference a b = sum $ zipWith (\x y -> (x-y)^2) a b
The performance of this code is really bad. Compressing a 256x256 image with a block size of 2 takes around 5 minutes despite compiling with -O2. Profiling shows me that most of the runtime is spent in the function distance, especially in sumSquareDifference, but also in toLists and toBinList:
binaryCompressionSimple +RTS -p -RTS
total time = 1430.89 secs (1430893 ticks # 1000 us, 1 processor)
total alloc = 609,573,757,744 bytes (excludes profiling overheads)
COST CENTRE MODULE SRC %time %alloc
sumSquareDifference Main binaryCompressionSimple.hs:87:1-63 30.9 28.3
toLists Main binaryCompressionSimple.hs:66:1-90 20.3 47.0
distance.toBinList Main binaryCompressionSimple.hs:74:11-79 10.9 15.1
main Main binaryCompressionSimple.hs:(14,1)-(24,21) 7.3 0.0
compress Main binaryCompressionSimple.hs:(28,1)-(36,60) 6.9 0.0
distance Main binaryCompressionSimple.hs:(71,1)-(74,79) 5.7 0.9
compress.distanceLists.\ Main binaryCompressionSimple.hs:34:38-65 5.2 4.4
compress.distanceLists Main binaryCompressionSimple.hs:34:11-74 2.8 0.0
main.\ Main binaryCompressionSimple.hs:20:72-128 2.7 0.0
getMinIndices.getMinIndex Main binaryCompressionSimple.hs:116:11-53 2.7 1.8
sumSquareDifference.\ Main binaryCompressionSimple.hs:87:52-58 2.7 2.5
Is there a way to improve performance?
A block size of 2 means comparing 16384 range blocks each with 131072 images of the domain pool, so sumSquareDifference will be called (16384*131072=)2147483648 times and calculate each time the sum square difference of two lists with length=4. I realize this is a large number but shouldn't the code be faster anyway (lazy evaluating of lists)? Is this a Haskell problem or an algorithm problem?
Edit:
I was able to at least improve the performance by a third by using:
distance :: Image VS X Bit -> Image VS X Bit-> Int
distance x y
| x == y = 0
| otherwise = sumSquareDifference (toBinList x) (toBinList y)
where toBinList = map (toNum . extractBitOfPixel) . concat . inlinedToLists
Edit 2:
I was able to increase the performance enormously by creating dPool with the function genDistanceList, which stops the calculation as soon as two identical images are found:
genDistanceList :: [[Image VS X Bit]] -> Image VS X Bit -> [[Int]]
genDistanceList dPool rBlock = nestedTakeWhileInclusive (/= 0) $ (map.map) (distance rBlock) dPool
The absolute first thing to try is skipping the conversion to lists:
{-# INLINE numIndex #-}
numIndex :: Image VS X Bit -> (Int, Int) -> Int
numIndex img pos = toNum . extractBitOfPixel $ index img pos
distance :: Image VS X Bit -> Image VS X Bit -> Int
distance a b = sum
[ (numIndex a pos - numIndex b pos)^2
| i <- [0 .. cols a-1]
, j <- [0 .. rows a-1]
, let pos = (i, j)
]
Since you haven't provided us with a minimal reproducible example, it's impossible to tell what effect, if any, that would have. If you want better advice, provide better data.
EDIT
Looking through the haddocks for hip, I suspect the following will be even better still:
distance :: Image VS X Bit -> Image VS X Bit -> Int
distance a b = id
. getX
. fold (+)
$ zipWith bitDistance a b
bitDistance :: Pixel X Bit -> Pixel X Bit -> Pixel X Int
bitDistance (PixelX a) (PixelX b) = PixelX (fromIntegral (a-b))
-- use (a-b)^2 when you switch to grayscale, but for Bit the squaring isn't needed
Here, the fold and zipWith are the ones provided by hip, not base.
I am currently trying to write a graphical application in haskell using OpenGL and GLFW-b. I am rather new to OpenGL, and I am having some problems displaying the TextureObjects. I have tried two ways of doing it.
The first way I tried was to store the textures as an TextureObject, and then simply using it as an input argument to the render function (see below). However, this doesn't work, as
the texture objects simply appear as white squares.
I will also note that it probably took several second for the program to start, presumably because it loaded all the graphics.
The second thing I tried was to store the textures as an IO TextureObject. This worked
, but it is very slow. It slows down to a few frames per second. I suspect this is because the textures need to be reloaded every time they are drawn. In order to test this, I renamed the textures while the program are running, and indeed the program crashed, confirming that it needs to reload the textures every iteration.
The texture is loaded with the function
loadTexture' :: FilePath -> IO TextureObject
loadTexture' f = do
tex <- either error id <$> readTexture f
textureFilter Texture2D $= ((Linear', Nothing), Linear')
return tex
and rendered with
renderTexture :: Area -> Area -> TextureObject -> IO()
renderTexture window area tex =
let (x,x') = xRangeToGL window $ getXRange area
(y,y') = yRangeToGL window $ getYRange area
in do textureBinding Texture2D $= Just tex
renderPrimitive Quads $ do
col
txc 1 1 >> ver x' y'
txc 1 0 >> ver x' y
txc 0 0 >> ver x y
txc 0 1 >> ver x y'
where col = color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
ver x y = vertex (Vertex2 x y :: Vertex2 GLfloat)
txc u v = texCoord (TexCoord2 u v :: TexCoord2 GLfloat)
The OpenGL settings are
clearColor $= Color4 r g b 1.0
depthFunc $= Just Lequal
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
normalize $= Enabled
texture Texture2D $= Enabled
shadeModel $= Smooth
This is my first post, so please tell me if I have missed something, and thank you for your kind assistance!
Bad practice solution:
I have come up with a solution, I have added it as an edit, rather than a solution, because I'm not certain that it is good practice --- it is not the type of answer I would like to have to this post, but it can still be of use to those who wish to answer.
Calling loadTexture using unsafeCoerce,
unsafePerformIO $ loadTexture "foo/bar.png"
works. However, rewriting the loadTexture' function as
loadTexture' :: FilePath -> IO TextureObject
loadTexture' f = do
let tex = unsafePerformIO $ either error id <$> readTexture f
textureFilter Texture2D $= ((Linear', Nothing), Linear')
return tex
does not work.
Given the following:
integralB :: Num a => Behavior t a -> Behavior t a -- definite integral of a behaviour
eJump :: Event t a -- tells the player to jump
bYAccel = pure 4000 -- y acceleration
bYVel = integralB bYAccel -- y velocity
bY = integralB bYVel -- y position
How do I make the player jump (probably by setting its y velocity) when a jump event arrives?
You'll need to be able to apply an impulse to the Y velocity for the jump. From your own answer, you've come up with a way to do so by summing all the impulses from the jumps and adding them to the integral of the acceleration.
Your acceleration is also constant. If you don't want the player falling constantly, you'd need something like:
bYAccel = (ifB airborne) 4000 0
airborne = fmap (>0) bY
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
One possible reason the height of your jumps varies is you aren't resetting the velocity when the player lands. If you have rules that hold the player above some position (like the floor), and are somehow stopping acceleration when the player hits the floor, you will also need to set the velocity to 0 if it is in the direction of the floor. (If you also set it to 0 when it's not in the direction of the floor, the player can never get the velocity to leave the ground.)
The reason this would cause erratic jumping heights is that the final velocity when the player lands will be close to the impulse you applied for them to take off. Using your numbers, if a jump started with a velocity of -5000, and ended with a velocity of 4800, the next jump will add an impulse of -5000, taking the jump to a starting velocity of only -200. That might have an ending velocity of 300, so the next jump will be an almost full -4700 jump.
Here's a complete working example. It uses the gloss library for input and display. The gameDefinition corresponds to the components introduced in your question. integrateDeltas is equivalent to your integralB, but produces events that are impulses, which are easy to generate in a clocked framework like gloss, and easy to use mixed with other events that cause impulses, like jumping.
{-# LANGUAGE RankNTypes #-}
module Main where
import Reactive.Banana
import Reactive.Banana.Frameworks.AddHandler
import Reactive.Banana.Frameworks
import Data.IORef
import qualified Graphics.Gloss.Interface.IO.Game as Gloss
gameDefinition :: GlossGameEvents t -> Behavior t Gloss.Picture
gameDefinition events = renderBehavior
where
bY = accumB 0 (fmap sumIfPositive yShifts)
yShifts = integrateDeltas bYVel
bYVel = accumB 0 yVelChanges
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
yVelShifts = union (integrateDeltas bYAccel) (fmap (const 3) eJump)
bYAccel = (ifB airborne) (-10) 0
airborne = fmap (>0) bY
eJump = filterE isKeyEvent (event events)
integrateDeltas = integrateDeltaByTimeStep (timeStep events)
renderBehavior = (liftA3 render) bY bYVel bYAccel
render y yVel yAccel =
Gloss.Pictures [
Gloss.Translate 0 (20+y*100) (Gloss.Circle 20),
Gloss.Translate (-50) (-20) (readableText (show y)),
Gloss.Translate (-50) (-40) (readableText (show yVel)),
Gloss.Translate (-50) (-60) (readableText (show yAccel))
]
readableText = (Gloss.Scale 0.1 0.1) . Gloss.Text
-- Utilities
sumIfPositive :: (Ord n, Num n) => n -> n -> n
sumIfPositive x y = max 0 (x + y)
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
integrateDeltaByTimeStep :: (Num n) => Event t n -> Behavior t n -> Event t n
integrateDeltaByTimeStep timeStep derivative = apply (fmap (*) derivative) timeStep
isKeyEvent :: Gloss.Event -> Bool
isKeyEvent (Gloss.EventKey _ _ _ _) = True
isKeyEvent _ = False
-- Main loop to run it
main :: IO ()
main = do
reactiveGame (Gloss.InWindow "Reactive Game Example" (400, 400) (10, 10))
Gloss.white
100
gameDefinition
-- Reactive gloss game
data GlossGameEvents t = GlossGameEvents {
event :: Event t Gloss.Event,
timeStep :: Event t Float
}
makeReactiveGameNetwork :: Frameworks t
=> IORef Gloss.Picture
-> AddHandler Gloss.Event
-> AddHandler Float
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> Moment t ()
makeReactiveGameNetwork latestFrame glossEvent glossTime game = do
eventEvent <- fromAddHandler glossEvent
timeStepEvent <- fromAddHandler glossTime
let
events = GlossGameEvents { event = eventEvent, timeStep = timeStepEvent }
pictureBehavior = game events
pictureChanges <- changes pictureBehavior
reactimate (fmap (writeIORef latestFrame) pictureChanges)
reactiveGame :: Gloss.Display
-> Gloss.Color
-> Int
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> IO ()
reactiveGame display color steps game = do
latestFrame <- newIORef Gloss.Blank
(glossEvent, fireGlossEvent) <- newAddHandler
(glossTime, addGlossTime) <- newAddHandler
network <- compile (makeReactiveGameNetwork latestFrame glossEvent glossTime game)
actuate network
Gloss.playIO
display
color
steps
()
(\world -> readIORef latestFrame)
(\event world -> fireGlossEvent event)
(\time world -> addGlossTime time)
In this example, bY checks for collision with a floor at 0 by accumulating the impulses, but constraining the accumulated value to be above 0.
The velocity, bYVel, accumulates all impulses while airborne, but only those impulses that are directed away from the floor while not airborne. If you change
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
to
yVelChanges = fmap (+) yVelShifts
it recreates the erratic jumping bug.
The acceleration, bYAccel, is only present while airborne.
I used a coordinate system with a +Y axis in the up direction (opposite the acceleration).
The code at the end is a small framework to hook reactive-banana up to gloss.
Solved it! I feel a little silly for not thinking of this earlier, but I just increment a counter every eJump and add that counter on to bYVel.
bJumpVel = sumB $ (-5000) <$ eJump
bYVel = (+) <$> bJumpVel <*> integralB bYAccel
-- gives the sum of the events
sumB :: Num a => Event t a -> Behavior t a
sumB e = accumB 0 $ (+) <$> e
For some reason the height of the jump always varies quite a bit, but that's probably an unrelated problem to do with my timing of things.
I won't mark this question as answered yet in case someone wants to share a better one.
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.
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)