daily pastebin goal
81%
SHARE
TWEET

QuadTree

a guest Apr 27th, 2015 227 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module QuadTree where
  2.  
  3. data Point = Point { getX :: Double, getY :: Double } deriving (Show)
  4.  
  5. data QTree
  6.     = Leaf (Point, Point)
  7.     | QS (Maybe Point) QTree QTree QTree QTree (Point, Point)
  8.     deriving (Show)
  9.  
  10. -- ---------
  11. -- | 3 | 2 |
  12. -- ---------
  13. -- | 0 | 1 |
  14. -- ---------
  15.  
  16. dlc :: QTree -> Point
  17. dlc (Leaf (p, _)) = p
  18. dlc (QS _ _ _ _ _ (p, _)) = p
  19.  
  20. urc :: QTree -> Point
  21. urc (Leaf (_, p)) = p
  22. urc (QS _ _ _ _ _ (_, p)) = p
  23.  
  24. mid :: Point -> Point -> Point
  25. mid p1 p2 = Point ((getX p1 + getX p2) / 2) ((getY p2 + getY p1) / 2)
  26.  
  27. getCorners :: Int -> Point -> Point -> Point -> (Point, Point)
  28. getCorners 0 d m _ = (d, m)
  29. getCorners 1 d m u = (Point (getX m) (getY d), Point (getX u) (getY m))
  30. getCorners 2 _ m u = (m, u)
  31. getCorners 3 d m u = (Point (getX d) (getY m), Point (getX m) (getY u))
  32.  
  33. contains :: Point -> Point -> Point -> Bool
  34. contains p c1 c2 = (getX p >= getX c1) && (getY p >= getY c1) &&
  35.                    (getX p < getX c2) && (getY p < getY c2)
  36.  
  37. insertQT :: Point -> QTree -> QTree
  38. insertQT p t
  39.     | contains p d u = addPoint p t
  40.     | otherwise = t
  41.     where
  42.         d = dlc t
  43.         u = urc t
  44.         m = mid d u
  45.         addPoint p (Leaf corners) =
  46.             QS (Just p)
  47.             (Leaf $ getCorners 0 d m u)
  48.             (Leaf $ getCorners 1 d m u)
  49.             (Leaf $ getCorners 2 d m u)
  50.             (Leaf $ getCorners 3 d m u)
  51.             corners
  52.         addPoint p (QS Nothing ld rd ru lu crn) =
  53.             QS Nothing
  54.             (insertQT p ld)
  55.             (insertQT p rd)
  56.             (insertQT p ru)
  57.             (insertQT p lu)
  58.             crn
  59.         addPoint p (QS (Just pnt) ld rd ru lu crn) =
  60.             addPoint p $ addPoint pnt (QS Nothing ld rd ru lu crn)
  61.  
  62. p1 = Point (-100.0) (-100.0)
  63. p2 = Point 100.0 100.0
  64. qt1 = Leaf (p1, p2)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top