Artifact collision in plane module

Here's something I tried putting together as I'm learning. Critiques on anything are welcome. There's also a logic bug in the Plane module I can't identify.

The long and the short are that it takes the URI "some float/some float/some float/some float", and makes the first 2 (x,y) coord where something is, and the second 2 (x,y) coord where it wants to go. If there are no things overlapping the desired space, it will return the coords of the new location. If there is an overlap, it will return the original coords.

Extra points if you can find the logic bug I've been trying to find where it's thinking all coords are a collision with something.

plane.hs:

module Plane where

type X = Float
type Y = Float
type Direction = Float
type Location = (X, Y)
type Size = (Float, Float)
type TopLeftCorner = Location
type TopRightCorner = Location
type BottomLeftCorner = Location
type BottomRightCorner = Location

data Shape = Rectangle deriving (Eq, Show)

data Corner = RectangleCorners {
topLeftCorner :: TopLeftCorner,
topRightCorner :: TopRightCorner,
bottomRightCorner :: BottomRightCorner,
bottomLeftCorner :: BottomLeftCorner}

data Artifact = Artifact {
shape :: Shape,
location :: Location,
size :: Size } deriving (Eq, Show)

type Plane = [Artifact]

moveArtifact :: Plane -> Artifact -> Location -> Artifact
moveArtifact plane originalArtifact (moveToX, moveToY)
| artifactCanGoToLoc = Artifact Rectangle (moveToX, moveToY) $size originalArtifact | otherwise = originalArtifact where artifactCorners = corners originalArtifact artifactCanGoToLoc = not$
topLeftCorner artifactCorners inside plane ||
topRightCorner artifactCorners inside plane ||
bottomRightCorner artifactCorners inside plane ||
bottomLeftCorner artifactCorners inside plane

corners :: Artifact -> Corner
corners (Artifact Rectangle (artifactX, artifactY) (artifactW,artifactH)) =
RectangleCorners
((-) artifactX $artifactW / 2, (+) artifactY$ artifactH / 2)
((+) artifactX $artifactW / 2, (+) artifactY$ artifactH / 2)
((+) artifactX $artifactW / 2, (-) artifactY$ artifactH / 2)
((-) artifactX $artifactW / 2, (-) artifactY$ artifactH / 2)

inside :: Location -> Plane -> Bool
inside x y = insideAcc False x y

insideAcc :: Bool -> Location -> Plane -> Bool
insideAcc False (locToCheckX, locToCheckY) (Artifact Rectangle (artifactX, artifactY) (artifactW,artifactH):artifacts) =
insideAcc
(upperRightX > locToCheckX &&
lowerLeftX < locToCheckX &&
upperRightY > locToCheckY &&
lowerLeftY < locToCheckY)
(locToCheckX, locToCheckY) artifacts
where
upperRightX = (+) artifactX $artifactW / 2 upperRightY = (+) artifactY$ artifactH / 2
lowerLeftX = (-) artifactY $artifactH / 2 lowerLeftY = (-) artifactX$ artifactW / 2

insideAcc _ _ _ = True

main.hs:

{-# LANGUAGE OverloadedStrings #-}
module Main (
main
) where

import Plane
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types (status200, status404)
import Blaze.ByteString.Builder (copyByteString)
import qualified Data.ByteString.UTF8 as BU
import Data.Monoid
import Data.Text (Text, unpack)

import Control.Applicative ((<*>),
(*>),
(<$>), (<|>), pure) import qualified Data.Attoparsec.Text as A import qualified Data.Attoparsec.Combinator as AC import Data.Attoparsec.Text (Parser) import Control.Monad.Trans.Resource import Network.HTTP.Types main :: IO () main = do let port = 3000 putStrLn$ "Listening on port " ++ show port
run port app

app :: Request -> ResourceT IO Response
app req = do
return $moveArtifactResponse path where path = pathInfo req moveArtifactResponse :: [Text] -> Response moveArtifactResponse splitPath@(oldX:oldY:newX:newY:_) = case (maybeArtifact, maybeX, maybeY) of (Just artifact, Just x, Just y) -> createJsonResponse$ show $location$ moveArtifact examplePlane (artifact) (x, y)
(_, _, _) -> notFoundResponse splitPath
where maybeArtifact = textToArtifact oldX oldY
maybeX = textToFloat newX
maybeY = textToFloat newY

moveArtifactResponse splitPath = notFoundResponse splitPath

notFoundResponse :: [Text] -> Response
notFoundResponse path =
createErrorResponse status200 $"404 NOT FOUND LOCATION READ AS: " ++ (show$ fmap textToFloatString path) ++ "<br/>" ++ (concat $fmap show examplePlane) createResponse :: BU.ByteString -> Status -> (String -> Response) createResponse contentType status response = do ResponseBuilder status [("Content-Type", contentType)] . mconcat . fmap copyByteString$ [BU.fromString response]

createErrorResponse = createResponse "text/html"
createJsonResponse = createResponse "text/javascript" status200
createHtmlResponse = createResponse "text/html" status200

textToFloat :: Text -> Maybe Float
textToFloat x
| (length $textReads x) /= 1 = Nothing | (snd$ head $textReads x) /= [] = Nothing | otherwise = Just$ fst $head$ textReads x
where textReads = reads . unpack :: Text -> [(Float, String)]

textToArtifact :: Text -> Text -> Maybe Artifact
textToArtifact textX textY =
case (maybeX, maybeY) of
(Just x, Just y) -> Just $Artifact Rectangle (x, y) (1,1) (_, _) -> Nothing where maybeX = textToFloat textX maybeY = textToFloat textY textToFloatString :: Text -> Maybe String textToFloatString x | textReads x == [] = Nothing | (snd$ head $textReads x) /= [] = Nothing | otherwise = Just$ unpack x
where textReads = reads . unpack :: Text -> [(Float, String)]

examplePlane :: Plane
examplePlane = [
Artifact Rectangle (3, 3) (2,2),
Artifact Rectangle (3, 8) (2,2),
Artifact Rectangle (8, 3) (2,2),
Artifact Rectangle (8, 8) (2,2)]
• On a side note, this is on github github.com/JimmyHoffa/HaskJunk – Jimmy Hoffa Jun 25 '12 at 4:45
• Sorry for missing the pragma- I didn't know what that was, leksah just puts it there, didn't know it did anything so I didn't copy it for this heh – Jimmy Hoffa Jun 25 '12 at 19:10

Here's the simplest rewrite I could come up with for your artifact collision detection algorithm:

module Plane where

type Location = (Float, Float)
type Size = (Float, Float)
data Artifact = Artifact { location :: Location, size :: Size }

xMin (Artifact (x, y) (w, h)) = x - w / 2
xMax (Artifact (x, y) (w, h)) = x + w / 2
yMin (Artifact (x, y) (w, h)) = y - h / 2
yMax (Artifact (x, y) (w, h)) = y + h / 2

type Plane = [Artifact]

moveArtifact :: Plane -> Location -> Artifact -> Maybe Artifact
moveArtifact plane newLoc oldArtifact =
if newArtifact collidesWith plane then Nothing else Just newArtifact
where newArtifact = oldArtifact { location = newLoc }

(locX, locY) isInsideOf a = xMin a < locX && locX < xMax a
&& yMin a < locY && locY < yMax a

mobileArtifact collidesWith plane = not . or $do x <- [xMin, xMax] y <- [yMin, yMax] let location = (x mobileArtifact, y mobileArtifact) existingArtifact <- plane return$ location isInsideOf existingArtifact

Your collision detection had two bugs. One was that you were mixing up X and Y coordinates:

lowerLeftX = (-) artifactY $artifactH / 2 lowerLeftY = (-) artifactX$ artifactW / 2

I think you meant to switch those.

The second bug was that your insideAcc function always returned True when it hit the empty list, regardless of what Bool value it currently had stored. This is why your collision detection always registered a collision.

Your artifact movement also had a bug, in that you were checking the original position of the artifact for collisions and not the new position.

Your insideAcc function was more complicated than it needed to be. A much simpler version is to use the any or or versions from the Prelude:

any :: (a -> Bool) -> [a] -> Bool

any p returns true if the predicate p evaluate to True for any value in the list.

or :: [Bool] -> Bool
or = any id

or just evaluates a list of boolean values and returns True if at least one is true.

In my rewrite, I used the or function to see of the list of returned Bools had any Trues.

I rewrote moveArtifact to return a Maybe Artifact, otherwise you'd have to use floating point equality to tell if your Artifact moved, which would work but would be kind of weird. You can always recover your original behavior by using the fromMaybe function which extracts a value from a Maybe, providing a default value (i.e. your original artifact) if it is a Nothing.

The most important trick I used when rewriting your code was the list monad (i.e. list comprehensions). This is a very useful trick when you need to do something on various permutations of certain values. The collision checking function checks every permutation of the three lists (i.e. [xMin, xMax], [yMin, yMax], and plane) for collisions.

• Would it be bad practice to use a guard in moveArtifact rather than the if then else? I really like your greatly reduced version of this whole thing! Much simpler than mine, I'll have to wrap my head around how you're using <-, thanks for the critiques and I'll have to remember to look for higher order functions like any/or in the future! Also, great thought to make it return a maybe so the consumer can decide if the reaction to Nothing is the old location or something else altogether. – Jimmy Hoffa Jun 27 '12 at 18:12
• @JimmyHoffa Using guards is just fine. To understand <-, I recommend first learning about list comprehensions, then learn about monads. Also, when searching for higher order functions, you can use Hoogle or Hayoo, which let you search for functions by type. – Gabriel Gonzalez Jun 27 '12 at 19:48

Here are some suggestions. Get rid of data types that do not carry their weight. For example, Shape should really be one of the constructors.

plane.hs

module Plane where

type X = Float
type Y = Float
type Location = (X, Y)
type Size = (Float, Float)

data Artifact = Rectangle {location :: Location,size :: Size }
deriving (Eq, Show)

type Plane = [Artifact]

moveArtifact :: Plane -> Artifact -> Location -> Artifact
moveArtifact plane original moveToXY
| canGoTo = Rectangle moveToXY $size original | otherwise = original where canGoTo = not$ any (flip inside plane) $corners original It seems the corner Datatype does not add much value. corners :: Artifact -> [Location] corners r = map (flip opapply r) [((-),(+)),((+),(+)),((+),(-)),((-),(-))] opapply :: (X -> Float -> X, Y -> Float -> Y) -> Artifact -> Location opapply (opx, opy) (Rectangle (x,y) (w,h)) = (x opx w / 2, y opy h / 2) inside :: Location -> Plane -> Bool inside l p = any (insideAcc l) p {- - ul ur - ll lr -} insideAcc :: Location -> Artifact -> Bool insideAcc (x, y) r = (urX > x && llX < x && urY > y && llY < y) where (urX,urY) = opapply ((+),(+)) r (llX,llY) = opapply ((-),(-)) r -- Main.hs {-# LANGUAGE OverloadedStrings, UnboxedTuples #-} module Main (main) where import Plane import Network.Wai import Network.Wai.Handler.Warp import Blaze.ByteString.Builder (copyByteString) import qualified Data.ByteString.UTF8 as BU import Data.Monoid import Data.Maybe import Data.Text (Text, unpack) import Control.Applicative ((<*>), (<$>))
import Network.HTTP.Types

main :: IO ()
main = do
let port = 3000
putStrLn $"Listening on port " ++ show port run port app app :: Request -> ResourceT IO Response app = return . moveArtifactResponse . pathInfo As before, be on the look out for generic functions pairApply :: (a -> Maybe b) -> (a,a) -> Maybe (b,b) pairApply fn (x,y) = (,) <$> fn x <*> fn y

Sometimes applicatives can make your code simpler.

moveArtifactResponse :: [Text] -> Response
moveArtifactResponse splitPath = fromMaybe (notFoundResponse splitPath) $case splitPath of (x:y:x':y':_) -> fn <$> textToArtifact (x, y) <*> pairApply textToFloat (x', y')
_ -> Nothing
where fn = ((createJsonResponse . show . location) .) . moveArtifact examplePlane

notFoundResponse :: [Text] -> Response
notFoundResponse path = createErrorResponse status200
$"404 NOT FOUND LOCATION READ AS: " ++ (show$ map textToFloatString path) ++ "<br/>" ++ concatMap show examplePlane

createResponse :: BU.ByteString -> Status -> (String -> Response)
createResponse contentType status response =  fn $[BU.fromString response] where fn = ResponseBuilder status [("Content-Type", contentType)] . mconcat . fmap copyByteString createErrorResponse = createResponse "text/html" createJsonResponse = createResponse "text/javascript" status200 createHtmlResponse = createResponse "text/html" status200 profit from our generic pairApply here. textToArtifact :: (Text, Text) -> Maybe Artifact textToArtifact textXY = pairApply textToFloat textXY >>= return . flip Rectangle (1,1) It should be possible to refactor the following two definitions. textToFloat :: Text -> Maybe Float textToFloat x | (length$ textReads x) /= 1 = Nothing
| (snd $head$ textReads x) /= [] = Nothing
| otherwise = Just $fst$ head $textReads x textToFloatString :: Text -> Maybe String textToFloatString x | textReads x == [] = Nothing | (snd$ head $textReads x) /= [] = Nothing | otherwise = Just$ unpack x

textReads = reads . unpack :: Text -> [(Float, String)]

examplePlane :: Plane
examplePlane = [Rectangle (3, 3) (2,2),Rectangle (3, 8) (2,2),
Rectangle (8, 3) (2,2), Rectangle (8, 8) (2,2)]
• Getting rid of shape makes sense, I like that. Also your simplification of insideAcc by using any in inside is nice. Thanks! I'm not certain of getting rid of position, or what exactly you're referring to I guess. – Jimmy Hoffa Jun 25 '12 at 19:08
• Oh I see- you got rid of the explicit corners. Yes, recognizing it as a list does make it much easier to work with I see, great insight! – Jimmy Hoffa Jun 25 '12 at 19:21
• @JimmyHoffa yes, I mentally parsed the four corners as position :) – rahul Jun 25 '12 at 21:26
• You're definition of 'generic functions' is very different from mine, but you're absolutely right, this makes sense. Thanks a lot! I'll really need to dig into applicatives more.. – Jimmy Hoffa Jun 26 '12 at 13:50
• I am looking for type generic functions, specifically combinators :) (should have used the later term instead?) – rahul Jun 26 '12 at 18:32