Take the 2-minute tour ×
Code Review Stack Exchange is a question and answer site for peer programmer code reviews. It's 100% free, no registration required.

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)]
share|improve this question
    
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
add comment

2 Answers

up vote 5 down vote accepted

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.

share|improve this answer
    
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
add comment

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)]
share|improve this answer
    
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
show 1 more comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.