Haskell draw image over image - haskell

I want to take two different images (taken from image files, like .png) and draw one over the other several times in different positions. The resulting image should be presented on screen or generate a new image file, whichever is easier. I´ll be taking that new image and drawing on it more with further operations
Is there any Haskell library that allows me to do this?

You can use JuicyPixels to do that sort of thing:
module Triangles where
import Codec.Picture
import LineGraphics
{-| Parameterize color smoothly as a function of angle -}
colorWheel :: Float -> Colour
colorWheel x = (r, g, b, a)
where
r = floor $ (cos x + 1) * (255 / 2)
g = floor $ (sin x + 1) * (255 / 2)
b = floor $ (cos (x+(pi/2)) + 1) * (255 / 2)
a = 255
{-| Draw a triangle centered about the point (x, y) -}
triangle :: Point -> Path
triangle (x, y) =
[ (x - k, y - k)
, (x + k, y - k)
, (x, y + k)
, (x - k, y - k)
]
where
size = 30
k = size / 2
{-|
Draw 'n' equally-spaced triangles at a radius of 'r' about a center
point, '(x, y)'.
-}
triangles :: Float -> Radius -> Vector -> Picture
triangles n r (x, y) =
[ (colorWheel theta, tri theta) | theta <- steps n ]
where
tri theta = triangle ((r * cos theta) + x, (r * sin theta) + y)
{-| Interpolate the range [0, 2pi] by 'n' steps -}
steps :: Float -> [Float]
steps n = map (\i -> i * (2*pi/n)) [0 .. n]
And we'll use this module of supporting code:
module LineGraphics (
Point, Vector, Line, Path, Picture, Colour, Radius,
black,
drawPicture,
) where
import Graphics.Rasterific hiding (Point, Vector, Line, Path, polygon)
import Graphics.Rasterific.Texture
import Codec.Picture
type Radius = Float
type Point = (Float, Float)
type Vector = (Float, Float)
type Line = (Point, Point)
type Path = [Point]
type Picture = [(Colour, Path)]
type Colour = (Int, Int, Int, Int) -- red, green, blue, opacity
black = (0, 0, 0, 255)
drawPicture :: Float -> Picture -> Image PixelRGBA8
drawPicture linewidth picture =
renderDrawing 800 800 (toColour black) $
mapM_ renderFn picture
where
renderFn (col, path) = withTexture (uniformTexture $ toColour col) (drawPath path)
drawPath points = stroke linewidth JoinRound (CapRound, CapStraight 0) $
polyline (map (\(x, y) -> V2 x y) points)
toColour (a,b,c,d) = PixelRGBA8
(fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)
And here's what we get:

Related

Quaternions rotation has a weird behaviour (Haskell OpenGL)

I've been following the Haskell OpenGL tutorial.
Rotations in a 3D space intrigued me so I started learning about Euler angles and finally, quaternions.
I wanted to implement my own function using quaternions to perform a rotation (on a cube), I've based myself on those two papers: mostly this one and this one.
My function works fine when I'm performing a rotation on only one axis, but when I do it on X and Y for example, the cube start to randomly go forward and being "blocked" when it rotates.
Video of the cube performing rotation on XY.
When I set the three axis (X, Y, Z), it zooms even more (but doesn't have that weird blocking thing): video.
Here is the code of my program:
Here is the main file that creates a window, set idle function and outputs result of rotation by angle A on the screen where A is increment by 0.05 at each frames.
module Main (main) where
import Core
import Utils
import Data.IORef
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL
main :: IO ()
main = do
createAWindow "177013"
mainLoop
createAWindow :: [Char] -> IO ()
createAWindow windowName = do
(procName, _args) <- getArgsAndInitialize
createWindow windowName
initialDisplayMode $= [DoubleBuffered]
angle <- newIORef 0.0
delta <- newIORef 0.05
displayCallback $= (start angle)
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboardMouse
idleCallback $= Just (idle angle delta)
reshape :: ReshapeCallback
reshape size = do
viewport $= (Position 0 0, size)
postRedisplay Nothing
keyboardMouse :: KeyboardMouseCallback
keyboardMouse _ _ _ _ = return ()
idle :: IORef GLfloat -> IORef GLfloat -> IdleCallback
idle angle delta = do
d <- get delta
a <- get angle
angle $~! (+d)
postRedisplay Nothing
start :: IORef GLfloat -> DisplayCallback
start angle = do
clear [ColorBuffer]
loadIdentity
a <- get angle
let c = rotate3f (0, 0, 0) [X,Y,Z] a $ cube3f 0.2 -- here I'm rotating on X, Y and Z axis
draw3f Quads c CCyan
flush
swapBuffers
where
Here is the core file where the rotation function is defined (with a few other ones). I added some comments as it's probably some low quality haskell code.
module Core (draw3f, vertex3f, rotate3f, translate3f, rotate3d, Colors(..), Axes(..)) where
import Control.Lens
import Graphics.Rendering.OpenGL
data Axes = X | Y | Z
deriving Eq
data Colors = CRed | CGreen | CBlue | CYellow | CWhite | CMagenta | CCyan | CBlack | CNone | CPreset
deriving Eq
rotate3f :: (GLfloat, GLfloat, GLfloat) -> [Axes] -> GLfloat -> [(GLfloat, GLfloat, GLfloat)] -> [(GLfloat, GLfloat, GLfloat)]
rotate3f _ _ _ [] = []
rotate3f _ [] _ _ = []
rotate3f o axes a p = let p' = translate3f p u -- translation if I don't want to rotate it by the origin
q = cos a' : ((\x -> if x `elem` axes then sin a' else 0) <$> [X,Y,Z]) -- if the axe is set then its related component is equal to sin theta/2, otherwise it will be 0
q' = q !! 0 : (negate <$> (tail q)) -- quaternion inversion
in translate3f ((rotate q q') <$> p') [(0,0,0),o] -- rotate and translate again to put the object where it belongs
where
a' = (a * (pi / 180)) / 2 -- convert to radians and divide by 2 as all q components takes theta/2
u :: [(GLfloat, GLfloat, GLfloat)]
u = [o,(0,0,0)]
rotate :: [GLfloat] -> [GLfloat] -> (GLfloat, GLfloat, GLfloat) -> (GLfloat, GLfloat, GLfloat)
rotate q q' (x,y,z) = let p = [0,x,y,z]
qmul q1 q2 = [(q1 !! 0) * (q2 !! 0) - (q1 !! 1) * (q2 !! 1) - (q1 !! 2) * (q2 !! 2) - (q1 !! 3) * (q2 !! 3),
(q1 !! 0) * (q2 !! 1) + (q1 !! 1) * (q2 !! 0) + (q1 !! 2) * (q2 !! 3) - (q1 !! 3) * (q2 !! 2),
(q1 !! 0) * (q2 !! 2) - (q1 !! 1) * (q2 !! 3) + (q1 !! 2) * (q2 !! 0) + (q1 !! 3) * (q2 !! 1),
(q1 !! 0) * (q2 !! 3) + (q1 !! 1) * (q2 !! 2) - (q1 !! 2) * (q2 !! 1) + (q1 !! 3) * (q2 !! 0)]
p' = qmul (qmul q p) q'
in (p' !! 1, p' !! 2, p' !! 3)
translate3f :: [(GLfloat, GLfloat, GLfloat)] -> [(GLfloat, GLfloat, GLfloat)] -> [(GLfloat, GLfloat, GLfloat)]
translate3f p [(ax,ay,az),(bx,by,bz)] = map (\(x,y,z) -> (x + (bx - ax), y + (by - ay), z + (bz - az))) p
draw3f :: PrimitiveMode -> [(GLfloat, GLfloat, GLfloat)] -> Colors -> IO()
draw3f shape points color = renderPrimitive shape $ mapM_ (\(x,y,z) -> vertex3f x y z color) points
vertex3f :: GLfloat -> GLfloat -> GLfloat -> Colors -> IO()
vertex3f x y z c = do
if c /= CPreset
then color $ Color3 (c' ^. _1) (c' ^. _2) ((c' ^. _3) :: GLfloat)
else return ()
vertex $ Vertex3 x y z
where
c' :: (GLfloat, GLfloat, GLfloat)
c' = case c of CRed -> (1,0,0)
CGreen -> (0,1,0)
CBlue -> (0,0,1)
CYellow -> (1,1,0)
CMagenta -> (1,0,1)
CCyan -> (0,1,1)
CBlack -> (0,0,0)
_ -> (1,1,1)
And here is the utils file where there's just the definition of the cube, from the Haskell OpenGL tutorial
module Utils (cube3f) where
import Core
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL
cube3f :: GLfloat -> [(GLfloat, GLfloat, GLfloat)]
cube3f w = [( w, w, w), ( w, w,-w), ( w,-w,-w), ( w,-w, w),
( w, w, w), ( w, w,-w), (-w, w,-w), (-w, w, w),
( w, w, w), ( w,-w, w), (-w,-w, w), (-w, w, w),
(-w, w, w), (-w, w,-w), (-w,-w,-w), (-w,-w, w),
( w,-w, w), ( w,-w,-w), (-w,-w,-w), (-w,-w, w),
( w, w,-w), ( w,-w,-w), (-w,-w,-w), (-w, w,-w)]
Finally, if it can helps people to see if there's a problem in my algorithms, here are some rotation samples using my function:
Rotation at 90°, of point (1, 2, 3) on X axis around point (0, 0, 0) (origin) gives: (0.99999994,-3.0,2.0)
Same rotation but on X & Y axis gives: (5.4999995,-0.99999994,-0.49999988)
Same rotation again but on X, Y and Z axis gives: (5.9999995,1.9999999,3.9999995)
The second paper about rotations by quaternions that you point to has this sentence:
“(x̂, ŷ, ẑ) is a unit vector that defines the axis of rotation.”.
So the quaternion has to be normalized, the sum of components squared being equal to 1.
So for example if you have all 3 axis involved, it has to be (cos θ/2, r3sin θ/2, r3sin θ/2, r3*sin θ/2) where r3 is the reciprocal of the square root of 3. This is how I would explain that the rotation results you mention at the end of your post fail to conserve the length of the vector when several axis are involved.
The critical piece is thus this line in function rotate3f:
q = cos a' : ((\x -> if x `elem` axes then sin a' else 0) <$> [X,Y,Z])
where a normalization factor is missing.
Your code offers a number of opportunities for readability improvement. You might consider using CodeReview for further details.
A major concern is the fact that the source code lines are too wide. If the reader has to use an horizontal slider, it is much more difficult to understand the code and find the bugs. Below, I will try to avoid going beyond 80 characters width.
First, we need some quaternion infrastructure:
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExplicitForAll #-}
type GLfloat = Float
type GLfloatV3 = (GLfloat, GLfloat, GLfloat)
type QuatFloat = [GLfloat]
data Axes = X | Y | Z deriving Eq
qmul :: QuatFloat -> QuatFloat -> QuatFloat
qmul [qa0, qa1, qa2, qa3] [qb0, qb1, qb2, qb3] =
[
qa0*qb0 - qa1*qb1 - qa2*qb2 - qa3*qb3 ,
qa0*qb1 + qa1*qb0 + qa2*qb3 - qa3*qb2 ,
qa0*qb2 - qa1*qb3 + qa2*qb0 + qa3*qb1 ,
qa0*qb3 + qa1*qb2 - qa2*qb1 + qa3*qb0
]
qmul _ _ = error "Quaternion length differs from 4"
qconj :: QuatFloat -> QuatFloat
qconj q = (head q) : (map negate (tail q)) -- q-conjugation
rotate :: [GLfloat] -> [GLfloat] -> GLfloatV3 -> GLfloatV3
rotate q q' (x,y,z) = let p = [0, x,y,z]
[q0,q1,q2,q3] = qmul (qmul q p) q'
in (q1, q2, q3)
Note that the idea of defining ad hoc types not only allows for reduced code width, but that also gives extra flexibility. If some day you decide to represent quaternions by some other data structure which is more efficient than a plain list, it can be done while leaving the client code unchanged.
Next, the rotation code proper. Function rotQuat0 is your initial algorithm, which reproduces the numerical results mentioned at the end of your question. Function rotQuat1 is the modified version giving a 1-normalized quaternion.
-- original code:
rotQuat0 :: [Axes] -> GLfloat -> QuatFloat
rotQuat0 axes angle = let fn x = if (x `elem` axes) then (sin angle) else 0
in (cos angle) : (map fn [X,Y,Z])
-- modified code:
rotQuat1 :: [Axes] -> GLfloat -> QuatFloat
rotQuat1 axes angle = let corr = 1.0 / sqrt (fromIntegral (length axes))
fn x = if (x `elem` axes) then corr*(sin angle) else 0
in (cos angle) : (map fn [X,Y,Z])
Code using rotQuat1:
rotate3f :: GLfloatV3 -> [Axes] -> GLfloat -> [GLfloatV3] -> [GLfloatV3]
rotate3f _ _ _ [] = []
rotate3f _ [] _ _ = []
rotate3f org axes degθ pts =
let -- convert to radians and divide by 2, as all q components take θ/2
a' = (degθ * (pi / 180)) / 2
u :: [GLfloatV3]
u = [org, (0,0,0)]
-- translation if I don't want to rotate it by the origin
p' = translate3f pts u
-- if the axis is set, then its related component is
-- equal to sin θ/2, otherwise it will be zero
---- q = cos a' : ((\x -> if x `elem` axes then sin a' else 0) <$> [X,Y,Z])
q = rotQuat1 axes a' -- modified version
q' = qconj q
-- rotate and translate again to put the object where it belongs
in translate3f ((rotate q q') <$> p') [(0,0,0), org]
translate3f :: [GLfloatV3] -> [GLfloatV3] -> [GLfloatV3]
translate3f pts [(ax,ay,az), (bx,by,bz)] =
let dx = bx - ax
dy = by - ay
dz = bz - az
in map (\(x,y,z) -> (x + dx, y + dy, z + dz)) pts
Testing code:
sqNorm3 :: GLfloatV3 -> GLfloat
sqNorm3 (x,y,z) = x*x + y*y +z*z
printAsLines :: Show α => [α] -> IO ()
printAsLines xs = mapM_ (putStrLn . show) xs
main = do
let pt = (1,2,3) :: GLfloatV3
pt1 = rotate3f (0,0,0) [X] 90 [pt]
pt2 = rotate3f (0,0,0) [X,Y] 90 [pt]
pt3 = rotate3f (0,0,0) [X,Y,Z] 90 [pt]
pts = map head [pt1, pt2, pt3]
ptN = map sqNorm3 pts
printAsLines pts
putStrLn " "
printAsLines ptN
Let's check that with function rotQuat1, the squared norm of your initial (1,2,3) input vector (that is 1+4+9=13) remains unchanged, as befits a proper rotation:
$ ghc opengl00.hs -o ./opengl00.x && ./opengl00.x
[1 of 1] Compiling Main ( opengl00.hs, opengl00.o )
Linking ./opengl00.x ...
(0.99999994,-3.0,2.0)
(3.6213198,-0.62132025,0.70710695)
(2.5773501,0.84529924,2.5773501)
14.0
13.999995
13.999998
$
Unfortunately I don't have enough time to install the OpenGL infrastructure and reproduce the animation. Please let us know whether this fixes the whole thing.

Raycaster displays phantom perpendicular wall faces

The output looks like this:
You should just see a flat, continuous red wall on one side, blue wall on another, green on another, yellow on another (see the definition of the map, testMapTiles, it's just a map with four walls). Yet there are these phantom wall faces of varying height, which are perpendicular to the real walls. Why?
Note that the white "gaps" aren't actually gaps: it's trying to draw a wall of height Infinity (distance 0). If you specifically account for it (this version of the code doesn't) and just cap it at screen height, then you just see a very high wall there.
The source code is below. It's plain Haskell, using Haste to compile to JavaScript and render to canvas. It is based on the C++ code from this tutorial, though note that I replaced mapX and mapY with tileX and tileY, and I don't have the ray prefix for pos and dir within the main loop. Any discrepancies from the C++ code are probably what's breaking everything, but I can't seem to find any after having pored over this code many times.
Any help?
import Data.Array.IArray
import Control.Arrow (first, second)
import Control.Monad (forM_)
import Haste
import Haste.Graphics.Canvas
data MapTile = Empty | RedWall | BlueWall | GreenWall | YellowWall deriving (Eq)
type TilemapArray = Array (Int, Int) MapTile
emptyTilemapArray :: (Int, Int) -> TilemapArray
emptyTilemapArray dim#(w, h) = listArray ((1, 1), dim) $ replicate (w * h) Empty
testMapTiles :: TilemapArray
testMapTiles =
let arr = emptyTilemapArray (16, 16)
myBounds#((xB, yB), (w, h)) = bounds arr
in listArray myBounds $ flip map (indices arr) (\(x, y) ->
if x == xB then RedWall
else if y == yB then BlueWall
else if x == w then GreenWall
else if y == h then YellowWall
else Empty)
type Vec2 a = (a, a)
type DblVec2 = Vec2 Double
type IntVec2 = Vec2 Int
add :: (Num a) => Vec2 a -> Vec2 a -> Vec2 a
add (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
mul :: (Num a) => Vec2 a -> a -> Vec2 a
mul (x, y) factor = (x * factor, y * factor)
rot :: (Floating a) => Vec2 a -> a -> Vec2 a
rot (x, y) angle =
(x * (cos angle) - y * (sin angle), x * (sin angle) + y * (cos angle))
dbl :: Int -> Double
dbl = fromIntegral
-- fractional part of a float
-- `truncate` matches behaviour of C++'s int()
frac :: Double -> Double
frac d = d - dbl (truncate d)
-- get whole and fractional parts of a float
split :: Double -> (Int, Double)
split d = (truncate d, frac d)
-- stops 'Warning: Defaulting the following constraint(s) to type ‘Integer’'
square :: Double -> Double
square = (^ (2 :: Int))
-- raycasting algorithm based on code here:
-- http://lodev.org/cgtutor/raycasting.html#Untextured_Raycaster_
data HitSide = NorthSouth | EastWest deriving (Show)
-- direction, tile, distance
type HitInfo = (HitSide, IntVec2, Double)
-- pos: start position
-- dir: initial direction
-- plane: camera "plane" (a line, really, perpendicular to the direction)
traceRays :: TilemapArray -> Int -> DblVec2 -> DblVec2 -> DblVec2 -> [HitInfo]
traceRays arr numRays pos dir plane =
flip map [0..numRays] $ \x ->
let cameraX = 2 * ((dbl x) / (dbl numRays)) - 1
in traceRay arr pos $ dir `add` (plane `mul` cameraX)
traceRay :: TilemapArray -> DblVec2 -> DblVec2 -> HitInfo
traceRay arr pos#(posX, posY) dir#(dirX, dirY) =
-- map tile we're in (whole part of position)
-- position within map tile (fractional part of position)
let ((tileX, fracX), (tileY, fracY)) = (split posX, split posY)
tile = (tileX, tileY)
-- length of ray from one x or y-side to next x or y-side
deltaDistX = sqrt $ 1 + (square dirY / square dirX)
deltaDistY = sqrt $ 1 + (square dirX / square dirY)
deltaDist = (deltaDistX, deltaDistY)
-- direction of step
stepX = if dirX < 0 then -1 else 1
stepY = if dirY < 0 then -1 else 1
step = (stepX, stepY)
-- length of ray from current position to next x or y-side
sideDistX = deltaDistX * if dirX < 0 then fracX else 1 - fracX
sideDistY = deltaDistY * if dirY < 0 then fracY else 1 - fracY
sideDist = (sideDistX, sideDistY)
(hitSide, wallTile) = traceRayInner arr step deltaDist tile sideDist
in (hitSide, wallTile, calculateDistance hitSide pos dir wallTile step)
traceRayInner :: TilemapArray -> IntVec2 -> DblVec2 -> IntVec2 -> DblVec2 -> (HitSide, IntVec2)
traceRayInner arr step#(stepX, stepY) deltaDist#(deltaDistX, deltaDistY) tile sideDist#(sideDistX, sideDistY)
-- a wall has been hit, report hit direction and coördinates
| arr ! tile /= Empty = (hitSide, tile)
-- advance until a wall is hit
| otherwise = case hitSide of
EastWest ->
let newSideDist = first (deltaDistX+) sideDist
newTile = first (stepX+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
NorthSouth ->
let newSideDist = second (deltaDistY+) sideDist
newTile = second (stepY+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
where
hitSide = if sideDistX < sideDistY then EastWest else NorthSouth
-- calculate distance projected on camera direction
-- (an oblique distance would give a fisheye effect)
calculateDistance :: HitSide -> DblVec2 -> DblVec2 -> IntVec2 -> IntVec2 -> Double
calculateDistance EastWest (startX, _) (dirX, _) (tileX, _) (stepX, _) =
((dbl tileX) - startX + (1 - dbl stepX) / 2) / dirX
calculateDistance NorthSouth (_, startY) (_, dirY) (_, tileY) (_, stepY) =
((dbl tileY) - startY + (1 - dbl stepY) / 2) / dirY
-- calculate the height of the vertical line on-screen based on the distance
calculateHeight :: Double -> Double -> Double
calculateHeight screenHeight 0 = screenHeight
calculateHeight screenHeight perpWallDist = screenHeight / perpWallDist
width :: Double
height :: Double
(width, height) = (640, 480)
main :: IO ()
main = do
cvElem <- newElem "canvas" `with` [
attr "width" =: show width,
attr "height" =: show height
]
addChild cvElem documentBody
Just canvas <- getCanvas cvElem
let pos = (8, 8)
dir = (-1, 0)
plane = (0, 0.66)
renderGame canvas pos dir plane
renderGame :: Canvas -> DblVec2 -> DblVec2 -> DblVec2 -> IO ()
renderGame canvas pos dir plane = do
let rays = traceRays testMapTiles (floor width) pos dir plane
render canvas $ forM_ (zip [0..width - 1] rays) (\(x, (side, tile, dist)) ->
let lineHeight = calculateHeight height dist
wallColor = case testMapTiles ! tile of
RedWall -> RGB 255 0 0
BlueWall -> RGB 0 255 0
GreenWall -> RGB 0 0 255
YellowWall -> RGB 255 255 0
_ -> RGB 255 255 255
shadedWallColor = case side of
EastWest ->
let (RGB r g b) = wallColor
in RGB (r `div` 2) (g `div` 2) (b `div` 2)
NorthSouth -> wallColor
in color shadedWallColor $ do
translate (x, height / 2) $ stroke $ do
line (0, -lineHeight / 2) (0, lineHeight / 2))
-- 25fps
let fps = 25
timeout = (1000 `div` fps) :: Int
rots_per_min = 1
rots_per_sec = dbl rots_per_min / 60
rots_per_frame = rots_per_sec / dbl fps
tau = 2 * pi
increment = tau * rots_per_frame
setTimeout timeout $ do
renderGame canvas pos (rot dir $ -increment) (rot plane $ -increment)
HTML page:
<!doctype html>
<meta charset=utf-8>
<title>Raycaster</title>
<noscript>If you're seeing this message, either your browser doesn't support JavaScript, or it is disabled for some reason. This game requires JavaScript to play, so you'll need to make sure you're using a browser which supports it, and enable it, to play.</noscript>
<script src=raycast.js></script>
The "phantom faces" are occurring because an incorrect HitSide is being reported: you're saying the face was hit on a horizontal move (EastWest), but was actually hit on a vertical move (NorthSouth), or vice-versa.
Why is it reporting an incorrect value, then? if sideDistX < sideDistY then EastWest else NorthSouth seems pretty foolproof, right? And it is.
The problem isn't how we calculated that value. It's when we calculated that value. The distance calculation function needs to know the direction we moved in to get to the wall. However, what we've actually given is the direction we would move in if we were to keep going (that is, if that tile wasn't a wall, or we were to ignore it for some reason).
Look at the Haskell code:
traceRayInner arr step#(stepX, stepY) deltaDist#(deltaDistX, deltaDistY) tile sideDist#(sideDistX, sideDistY)
-- a wall has been hit, report hit direction and coördinates
| arr ! tile /= Empty = (hitSide, tile)
-- advance until a wall is hit
| otherwise = case hitSide of
EastWest ->
let newSideDist = first (deltaDistX+) sideDist
newTile = first (stepX+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
NorthSouth ->
let newSideDist = second (deltaDistY+) sideDist
newTile = second (stepY+) tile
in
traceRayInner arr step deltaDist newTile newSideDist
where
hitSide = if sideDistX < sideDistY then EastWest else NorthSouth
Notice that we do things in this order:
calculate hitSide
check if a wall has been hit, and if so, report hitSide
move
Compare this to the original C++ code:
//perform DDA
while (hit == 0)
{
//jump to next map square, OR in x-direction, OR in y-direction
if (sideDistX < sideDistY)
{
sideDistX += deltaDistX;
mapX += stepX;
side = 0;
}
else
{
sideDistY += deltaDistY;
mapY += stepY;
side = 1;
}
//Check if ray has hit a wall
if (worldMap[mapX][mapY] > 0) hit = 1;
}
It does things in a different order:
check if a wall has been hit, and if so, report side (equivalent to hitSide)
move and calculate side
The C++ code only calculates side when it moves, and then it reports that value if it hits a wall. So, it reports the way it moved in order to hit the wall.
The Haskell code calculates side whether or not it moves: so it's correct for each move, but when it hits a wall, it reports the way it would have moved were it to keep going.
So, the Haskell code can be fixed by re-ordering it so that it checks for a hit after moving, and if so, reports the hitSide value from that move. This isn't pretty code, but it works:
traceRayInner arr step#(stepX, stepY) deltaDist#(deltaDistX, deltaDistY) tile sideDist#(sideDistX, sideDistY) =
let hitSide = if sideDistX < sideDistY then EastWest else NorthSouth
in case hitSide of
EastWest ->
let newSideDist = first (deltaDistX+) sideDist
newTile = first (stepX+) tile
in case arr ! newTile of
-- advance until a wall is hit
Empty -> traceRayInner arr step deltaDist newTile newSideDist
-- a wall has been hit, report hit direction and coördinates
_ -> (hitSide, newTile)
NorthSouth ->
let newSideDist = second (deltaDistY+) sideDist
newTile = second (stepY+) tile
in case arr ! newTile of
-- advance until a wall is hit
Empty -> traceRayInner arr step deltaDist newTile newSideDist
-- a wall has been hit, report hit direction and coördinates
_ -> (hitSide, newTile)
Problem solved!
Side note: I figured out what was wrong after carrying out the algorithm on paper. While in that particular case it just so happened the last two HitSide values matched, it became obvious that that they might not in every case. So, a big thanks to Madsy on Freenode's #algorithms for suggesting trying it out on paper. :)

Create a method acting on different types in Haskell

I'm trying to use different data types in a list. e.g:
data Shape = Square Int
| Circle Int
| Rectangle Int Int
| Triangle Int Int Int
deriving (Show)
shapes = [Square 5, Circle 2, Rectangle 10 5]
showShapes :: [Shape] -> [Int]
showShapes [] = []
showShapes (s:xs) = getArea (s : xs)
However I'm struggling to create the method "getArea" as I need one for each different type. I don't know a way to do this using parameter pattern matching. Is there a way to do this or am I tackling this problem the wrong way?
Edit
How would you do it using an if statement and "typeOf" function
I tried changing Shape to this:
data Shape = Square Int
| Rectangle Int Int
| Triangle Int Int Int
deriving (Show, Typeable)
But I get a compile time error!
For your simple case, just use pattern matching in getArea, but you'll have to convert your values to Doubles since the area of a circle is never going to be an integer when you have an integer radius:
getArea :: Shape -> Double
getArea (Square l) = fromIntegral $ l * l
getArea (Circle r) = pi * fromIntegral r ^ 2
getArea (Rectangle l w) = fromIntegral $ l * w
-- assuming the constructor takes the 3 side lengths
getArea (Triangle a b c) = sqrt $ p * (p - a') * (p - b') * (p - c')
where
[a', b', c'] = map fromIntegral [a, b, c]
p = (a' + b' + c') / 2
Although I don't know what you want to do in showShapes. Usually the word show in Haskell means the same thing as toString in other languages, but you're trying to apply getArea inside it. Regardless, your pattern matching for showShapes is off, you need parentheses around s:xs or you'll get a syntax error, and you can't prepend a number on front of a list of Shapes as with getArea s : xs. Instead you might be wanting to calculate the area for each shape in a list? For that you can use map:
getAreas :: [Shape] -> [Double]
getAreas shapes = map getArea shapes
Note, that you don't need to store all figures in one datatype in this case. You can use existential quantification instead:
{-# LANGUAGE ExistentialQuantification #-}
data Square = Square Int
data Circle = Circle Int
data Rectangle = Rectangle Int Int
class HasArea a where
area :: a -> Double
instance HasArea Square where
area (Square n) = fromIntegral n * fromIntegral n
instance HasArea Circle where
area (Circle r) = pi * fromIntegral r ^ 2
instance HasArea Rectangle where
area (Rectangle n m) = fromIntegral n * fromIntegral m
data Shape = forall s. HasArea s => Shape s
shapes :: [Shape]
shapes = [Shape (Square 5), Shape (Circle 2), Shape (Rectangle 10 5)]
shapeArea :: Shape -> Double
shapeArea (Shape s) = area s
main = print $ map shapeArea shapes
You can read about existential quantification here: http://en.wikibooks.org/wiki/Haskell/Existentially_quantified_types
Existential quantification itself is weaker, than generalized algebraic datatypes. You can read about them here: http://en.wikibooks.org/wiki/Haskell/GADT

"Overloaded" value constructors

In "Making Our Own Types and Typeclasses" they give the following piece of code :
data Point = Point Float Float deriving (Show)
data Shape = Circle Point Float | Rectangle Point Point deriving (Show)
surface :: Shape -> Float
surface (Circle _ r) = pi * r ^ 2
surface (Rectangle (Point x1 y1) (Point x2 y2)) = (abs $ x2 - x1) * (abs $ y2 - y1)
nudge :: Shape -> Float -> Float -> Shape
nudge (Circle (Point x y) r) a b = Circle (Point (x+a) (y+b)) r
nudge (Rectangle (Point x1 y1) (Point x2 y2)) a b = Rectangle (Point (x1+a) (y1+b)) (Point (x2+a) (y2+b))
main = do
print (surface (Circle (Point 0 0) 24))
print (nudge (Circle (Point 34 34) 10) 5 10)
As it stands the pattern matching against constructors is getting quite cluttered at the point
nudge (Rectangle (Point x1 y1) (Point x2 y2)) a b = ....
Had we defined the Shape type as :
data Shape = Circle Point Float | Rectangle Float Float Float Float deriving (Show)
Then even though we lose a bit of clarity into the nature of the type, the patten matching looks less cluttered, as can be seen below :
data Point = Point Float Float deriving (Show)
data Shape = Circle Point Float | Rectangle Float Float Float Float deriving (Show)
surface :: Shape -> Float
surface (Circle _ r) = pi * r ^ 2
surface (Rectangle x1 y1 x2 y2) = (abs $ x2 - x1) * (abs $ y2 - y1)
nudge :: Shape -> Float -> Float -> Shape
nudge (Circle (Point x y) r) a b = Circle (Point (x+a) (y+b)) r
nudge (Rectangle x1 y1 x2 y2) a b = Rectangle (x1+a) (y1+b) (x2+a) (y2+b)
main = do
print (surface (Circle (Point 0 0) 24))
print (nudge (Circle (Point 34 34) 10) 5 10)
My question is whether it is possible to have both
Rectangle Point Point
and
Rectangle Float Float Float Float
in the same piece of code (i.e. a sort of "overloading" of value constructors), so that we can do something like :
...
surface (Rectangle (Point x1 y1) (Point x2 y2)) = (abs $ x2 - x1) * (abs $ y2 - y1)
...
nudge (Rectangle x1 y1 x2 y2) a b = Rectangle (x1+a) (y1+b) (x2+a) (y2+b)
where the "..." denotes the same as in the code above. Also are there any other tricks to make the notation a bit more compact at the "nudge (Rectangle...." point? Thanks
You could possibly use type classes to make a function behave as both Point -> Point -> Rectangle and Float -> Float -> Float -> Float -> Rectangle, but I wouldn't advocate it. It will be to much trouble for the gain. I don't think there's anyway you could make such an overloaded name usable in pattern matching anyway.
The way I see it, if you're only ever going to be using Point values by deconstructing them and operating on the raw Float values, then you're not really getting that much out of it, so you could resolve your problem by getting rid of it entirely.
But you're missing a golden opportunity to implement a function to adjust a point directly!
For starters I would make an Offset type to hold your a and b values. Then you make a function adjust :: Offset -> Point -> Point to do the combining. And then your nudge doesn't even need to understand the internal structure of a Point to do its job!
For example (Disclaimer: I haven't actually compiled this)1:
data Point = Point Float Float deriving (Show)
data Offset = Offset Float Float deriving (Show)
data Shape = Circle Point Float | Rectangle Point Point deriving (Show)
adjust :: Point -> Offset -> Point
adjust (Point x y) (Offset ox oy) = Point (x + ox) (y + oy)
nudge :: Shape -> Offset -> Shape
nudge (Circle c r) o = Circle (adjust c o) r
nudge (Rectangle p1 p2) o = Rectangle (adjust p1 o) (adjust p2 o)
And similarly there could be a whole family of operations on Point and Offset. For example offsetFrom :: Point -> Point -> Offset could be useful in your surface function. I once went overboard and used type classes to implement a family of operators (|+|, |*|, etc IIRC) which allowed various things to be combined (for example, you can add a Point and an Offset in either order to get a Point, you can add and subtract Offsets but not Points, you can multiply Offsets by scalars but not Points, etc). Not sure whether it was worth it in the end, but it made my code look like my maths a little more!
With your current code you're effectively implementing all operations on Point again every time you need them (including the same adjustment operation twice in the same equation in nudge, which is my take on why it looks quite so bad).
1 There's a certain argument to be made for making functions like adjust and nudge have signatures where the "main" thing being operated on comes last, so adjust :: Offset -> Point -> Point and nudge :: Offset -> Shape -> Shape. This can come in handy because then partially applying adjust gives you a "point transformer" with type Point -> Point, and similarly you can partially apply nudge to get a "shape transformer" with type Shape -> Shape.
This helps when you have a collection of points or shapes and you want to apply the same transformation to all of them, for example:
data Shape = Polygon [Point]
adjust :: Offset -> Point -> Point
adjust (Offset ox oy) (Point x y) = Point (x + ox) (y + oy)
nudge :: Offset -> Shape -> Shape
nudge o (Polygon ps) = Polygon (map (adjust o) ps)
And generally "transformers" with type Something -> Something are just useful things to have on your main data structures. So whenever you have a function that combines some auxiliary data with a Something to produce a new Something, it'll often turn out to be useful to put the Something as the last argument, so you have another easy source of transformer functions.
One option would be to use view patterns. Let me give you a short example:
{-# LANGUAGE ViewPatterns #-}
data Point = Point Float Float
data Shape = Circle Point Float | Rectangle Point Point
rectangleAsPoints :: Shape -> Maybe (Point,Point)
rectangleAsPoints (Rectangle a b) = Just (a,b)
rectangleAsPoints _ = Nothing
rectangleFromPoints :: Point -> Point -> Shape
rectangleFromPoints = Rectangle
rectangleAsCoords :: Shape -> Maybe (Float,Float,Float,Float)
rectangleAsCoords (Rectangle (Point x y) (Point a b)) = Just (x,y,a,b)
rectangleAsCoords _ = Nothing
rectangleFromCoords :: Float -> Float -> Float -> Float -> Shape
rectangleFromCoords a b c d = Rectangle (Point a b) (Point c d)
surface (rectangleAsPoints -> Just (Point x1 y1, Point x2 y2)) =
(abs $ x2 - x1) * (abs $ y2 - y1)
surface (Circle _ r) = pi * r ^ 2
nudge (rectangleAsCoords -> Just (x1,y1,x2,y2)) a b =
rectangleFromCoords (x1+a) (y1+b) (x2+a) (y2+b)
nudge (Circle (Point x y) r) a b = Circle (Point (x+a) (y+b)) r
For consistency's sake I implemented both views of rectangles as functions. This way the actual implementation of the Rectangle type can remain hidden.
Note how you can mix normal pattern matching and view patterns.
What you want is't possibile. For the purposes of pattern matching you could use ViewPatterns as a poor-mans replacement for multiple constructors and make a single function to ease construction:
{-# LANGUAGE ViewPatterns #-}
-- Your pattern match aid
unRectangle :: Shape -> Maybe (Float, Float, Float, Float)
unRectangle (Rectangle (Point x1 y1) (Point x2 y2)) = Just (x1,y1,x2,y2)
unRectangle _ = Nothing
-- your construction aid
rectangle :: Float -> Float -> Float -> Float -> Shape
rectangle x y u v = Rectangle (Point x y) (Point u v)
surface (unRectangle -> Just (x1,y1,x2,y2)) = (abs $ x2 - x1) * (abs $ y2 - y1)
...
nudge (unRectangle -> Just (x1,y1,x2,y2)) = rectangle (x1+a) (y1+b) (x2+a) (y2+b)

type error in Haskell

I am getting the following error:
exercise-2-2.hs:15:49:
Couldn't match expected type `Double' with actual type `Int'
In the fourth argument of `regularPolygonHelper', namely `theta'
In the expression: regularPolygonHelper n s 0 theta r
In an equation for `regularPolygon':
regularPolygon n s
= regularPolygonHelper n s 0 theta r
where
r = s / 2.0 * (sin (pi / n))
theta = (2.0 * pi) / n
in the following code:
data Shape = Rectangle Side Side
| Ellipse Radius Radius
| RTTriangle Side Side
| Polygon [Vertex]
deriving Show
type Radius = Float
type Side = Float
type Vertex = (Float, Float)
square s = Rectangle s s
circle r = Ellipse r r
regularPolygon :: Int -> Side -> Shape
regularPolygon n s = regularPolygonHelper n s 0 theta r
where r = s / 2.0 * (sin (pi / n))
theta = (2.0 * pi) / n
regularPolygonHelper :: Int -> Side -> Int -> Double -> Double -> Shape
regularPolygonHelper 0 s i theta r = Polygon []
regularPolygonHelper n s i theta r =
(r * cos (i * theta), r * sin (i * theta)) :
(regularPolygonHelper (n - 1) s (i + 1) theta r)
Why is this? Isn't (2.0 * pi) / n a double?
Haskell has no automatic conversion between different numeric types. You have to do this by hand. In your case, (2.0 * pi) / fromIntegral n would do the trick. (You have to add this at all the other places where you want to have a cast too) The reason for this is, that implicit conversion would make type inference much harder, IMHO it is better to have type inference than automatic conversion.
better not mix the types so much
here is a version that compiles so far:
data Shape = Rectangle Side Side
| Ellipse Radius Radius
| RTTriangle Side Side
| Polygon [Vertex]
deriving Show
type Radius = Double
type Side = Double
type Vertex = (Double, Double)
square s = Rectangle s s
circle r = Ellipse r r
regularPolygon :: Int -> Side -> Shape
regularPolygon n s = regularPolygonHelper n s 0 theta r
where r = s / 2.0 * (sin (pi / fromIntegral n))
theta = (2.0 * pi) / fromIntegral n
regularPolygonHelper :: Int -> Side -> Int -> Double -> Double -> Shape
regularPolygonHelper 0 s i theta r = Polygon []
regularPolygonHelper n s i theta r =
let Polygon rPoly = regularPolygonHelper (n - 1) s (i + 1) theta r in
Polygon ((r * cos (fromIntegral i * theta), r * sin (fromIntegral i * theta)) : rPoly)

Resources