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

• Jimmy Hoffa: On a side note, this is on github github.com/JimmyHoffa/HaskJunk
• Jimmy Hoffa: 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

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.

• Jimmy Hoffa: 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.
• Gabriella Gonzalez: @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.

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

• Jimmy Hoffa: 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: 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!
• Rahul Gopinath: @JimmyHoffa yes, I mentally parsed the four corners as position :)
• Jimmy Hoffa: 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..
• Rahul Gopinath: I am looking for type generic functions, specifically combinators :) (should have used the later term instead?)