Artifact collision in plane module

Question

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)]

Answer 1

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

Some comments:

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.

Answer 2

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 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 = 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)]