0_quadtree.png

quadtree.hs

module Quadtree
( Box (Box)
, box_x1
, box_y1
, box_x2
, box_y2
, BoxGeometry
, width
, height
, x1
, y1
, x2
, y2
, halfWidth
, halfHeight
, QuadTree
, QuadTreeItem
, quadtreeItemBox
, intersectBoxes
, emptyQuadTree
, countQuadtree
, insertQuadtree
, findQuadtreeItems
, removeQuadtreeItem
, moveQuadtreeItem 
, renderBoxToHtml
, renderQuadtreeToHtml
) where

import Text.Printf

--import System.Random
import Data.List
import Data.List.Split



-- http://hackage.haskell.org/package/gloss-1.3.0.1/docs/src/Graphics-Gloss-Data-QuadTree.html

-- quadtree types

data Box = Box { box_x1 :: Integer, box_y1 :: Integer, box_x2 :: Integer, box_y2 :: Integer } deriving Show

--data QuadTreeItem a = QuadTreeItem Box a deriving Show

data QuadTree a = TLeaf Box [a]
                | TNode Box (QuadTree a) (QuadTree a) (QuadTree a) (QuadTree a)
                deriving Show

-- match type class
class BoxGeometry a where
    width :: a -> Integer
    height :: a -> Integer
    x1 :: a -> Integer
    y1 :: a -> Integer
    x2 :: a -> Integer
    y2 :: a -> Integer

    halfWidth :: a -> Integer
    halfWidth a = (width a) `div` 2
    halfHeight :: a -> Integer
    halfHeight a = (height a) `div` 2


boxWidth box = (x2 box) - (x1 box)
boxHeight box = (y2 box) - (y1 box)

boxHalfWidth box = (boxWidth box) `div` 2
boxHalfHeight box = (boxHeight box) `div` 2

instance BoxGeometry Box where
    width = boxWidth
    height = boxHeight
    x1 = box_x1
    y1 = box_y1
    x2 = box_x2
    y2 = box_y2


class (Ord a, BoxGeometry a) => QuadTreeItem a


quadtreeItemBox :: (BoxGeometry a) => a -> Box
quadtreeItemBox item = Box { box_x1 = x1 item, box_y1 = y1 item,
                             box_x2 = x2 item, box_y2 = y2 item }

-- box math
intersectBoxes :: Box -> Box -> Bool
intersectBoxes box_a box_b = not (aLeftOfB || aRightOfB || aAboveB || aBelowB)
        where
            aLeftOfB = (x2 box_a) < (x1 box_b)
            aRightOfB = (x1 box_a) > (x2 box_b)
            aAboveB = (y1 box_a) > (y2 box_b)
            aBelowB = (y2 box_a) < (y1 box_b)

subdivideNW box = Box {
        box_x1 = (x1 box),
        box_y1 = (y1 box),
        box_x2 = (x1 box) + (halfWidth box),
        box_y2 = (y1 box) + (halfHeight box)
    }

subdivideNE box = Box {
        box_x1 = (x1 box) + (halfWidth box),
        box_y1 = (y1 box),
        box_x2 = (x2 box),
        box_y2 = (y1 box) + (halfHeight box)
    }

subdivideSE box = Box {
        box_x1 = (x1 box) + (halfWidth box),
        box_y1 = (y1 box) + (halfHeight box),
        box_x2 = (x2 box),
        box_y2 = (y2 box)
    }

subdivideSW box = Box {
        box_x1 = (x1 box),
        box_y1 = (y1 box) + (halfWidth box),
        box_x2 = (x1 box) + (halfHeight box),
        box_y2 = (y2 box)
    }

emptyQuadTree :: Box -> QuadTree a
emptyQuadTree box = TLeaf box []

-- count items
countQuadtree :: QuadTree a -> Integer
countQuadtree (TLeaf box items) = toInteger $ length items

countQuadtree (TNode box quadtree_a quadtree_b quadtree_c quadtree_d) =
        (countQuadtree quadtree_a)
        + (countQuadtree quadtree_b)
        + (countQuadtree quadtree_c)
        + (countQuadtree quadtree_d)

-- insert


insertQuadtree :: (QuadTreeItem a) => a -> QuadTree a -> QuadTree a
insertQuadtree item quadtree@(TLeaf box items)
        | (intersectBoxes add_item_box box) && (length all_items) < 10 = TLeaf box all_items
        | (intersectBoxes add_item_box box) = TNode box -- spill over
            (foldr (\item quadtree -> insertQuadtree item quadtree) (emptyQuadTree box_nw) all_items)
            (foldr (\item quadtree -> insertQuadtree item quadtree) (emptyQuadTree box_ne) all_items)
            (foldr (\item quadtree -> insertQuadtree item quadtree) (emptyQuadTree box_se) all_items)
            (foldr (\item quadtree -> insertQuadtree item quadtree) (emptyQuadTree box_sw) all_items)
        | otherwise = quadtree
    where
        add_item_box = quadtreeItemBox item
        box_nw = subdivideNW box
        box_ne = subdivideNE box
        box_se = subdivideSE box
        box_sw = subdivideSW box
        all_items = item : items

insertQuadtree item quadtree@(TNode box quadtree_nw quadtree_ne quadtree_se quadtree_sw)
        | intersectBoxes add_item_box box = (TNode box
            (insertQuadtree item quadtree_nw)
            (insertQuadtree item quadtree_ne)
            (insertQuadtree item quadtree_se)
            (insertQuadtree item quadtree_sw))
        | otherwise = quadtree
    where
        add_item_box = quadtreeItemBox item


-- query
rmdups :: (Ord a) => [a] -> [a]
rmdups = map head . group . sort

findQuadtreeItems :: (QuadTreeItem a) => QuadTree a -> (Box -> Bool) -> [a]
findQuadtreeItems (TLeaf box items) intersect
    | intersect box = rmdups [item | item <- items, intersect (quadtreeItemBox item)]
    | otherwise = []

findQuadtreeItems (TNode box quadtree_nw quadtree_ne quadtree_se quadtree_sw) intersect =
    (findQuadtreeItems quadtree_nw intersect)
    ++ (findQuadtreeItems quadtree_ne intersect)
    ++ (findQuadtreeItems quadtree_se intersect)
    ++ (findQuadtreeItems quadtree_sw intersect)


-- removal
removeQuadtreeItem :: (QuadTreeItem a) => QuadTree a -> a -> QuadTree a
removeQuadtreeItem (TLeaf box items) remove_item = TLeaf box [item | item <- items, item /= remove_item]

removeQuadtreeItem (TNode box quadtree_nw quadtree_ne quadtree_se quadtree_sw) remove_item = TNode box
    (removeQuadtreeItem quadtree_nw remove_item)
    (removeQuadtreeItem quadtree_ne remove_item)
    (removeQuadtreeItem quadtree_se remove_item)
    (removeQuadtreeItem quadtree_sw remove_item)


-- move (faster than removing & inserting?)
moveQuadtreeItem quadtree move_item = insertQuadtree move_item $ removeQuadtreeItem quadtree move_item


-- rendering
tabOver :: String -> String
tabOver str = intercalate "\n" ["  " ++ str | str <- splitOn "\n" str]


render_scale = 5
renderBoxToHtml box color = printf
            "<div style=\"position: absolute; left: %dpx; top: %dpx; width: %dpx; height: %dpx; border: 1px solid %s; opacity: 0.5;\"></div>\n"
            ((box_x1 box) * render_scale + 10) ((box_y1 box) * render_scale + 10)
            ((width box) * render_scale) ((height box) * render_scale)
            color


renderQuadtreeToHtml :: (BoxGeometry a) => QuadTree a -> String
renderQuadtreeToHtml quadtree@(TLeaf box items) = tabOver (
        renderBoxToHtml box "black"
        ++ (foldr (++) "" (map (\item -> renderBoxToHtml (quadtreeItemBox item) "red") items))
      )

renderQuadtreeToHtml quadtree@(TNode box quadtree_a quadtree_b quadtree_c quadtree_d) =
        "<!-- quadtree spill -->\n"
        ++ tabOver(
            (renderQuadtreeToHtml quadtree_a)
            ++ (renderQuadtreeToHtml quadtree_b)
            ++ (renderQuadtreeToHtml quadtree_c)
            ++ (renderQuadtreeToHtml quadtree_d)
        )

-- testing

quadtree_test.hs

import System.Random
import Data.List
import Text.Printf
import Data.List.Split

import Quadtree


data Object = Object {
    object_box :: Box,
    object_id :: Integer,
    object_name :: String
} deriving Show

instance QuadTreeItem Object

instance BoxGeometry Object where
    width = width . object_box
    height = height . object_box
    x1 = x1 . object_box
    y1 = y1 . object_box
    x2 = x2 . object_box
    y2 = y2 . object_box

instance Ord Object where
    a `compare` b = (object_id a) `compare` (object_id b)

instance Eq Object where
    a == b = (object_id a) == (object_id b)


getRandomNumber :: Integer -> Integer -> IO Integer
getRandomNumber num_min num_max = do
    g <- getStdGen
    return (fst $ randomR (num_min, num_max) g)

randomlist :: Int -> StdGen -> [Int]
randomlist n = (take n . unfoldr (Just . randomR (1, 98)))



main = do
    seed_x <- newStdGen
    seed_y <- newStdGen

    let positions = zip ([toInteger i | i <- randomlist 200 seed_x])
                        ([toInteger i | i <- randomlist 200 seed_y])

    --let positions = [(x * 4, y * 4) | x <- [0..24], y <- [0..24]]

    let quadtree_items = [(Object {
                            object_box = Box { box_x1 = x1, box_y1 = y1, box_x2 = x1 + 2, box_y2 = y1 + 2 },
                            object_id = x1 + (y1 * 100),
                            object_name = "hello"
                          }) | (x1, y1) <- positions]

    let full_tree = foldr (\quadtree_item quadtree -> insertQuadtree quadtree_item quadtree)
                          (emptyQuadTree Box { box_x1 = 0, box_y1 = 0, box_x2 = 100, box_y2 = 100 })
                          quadtree_items


    putStrLn $ ("full tree: " ++ (show $ full_tree))
    putStrLn $ ("items in tree: " ++ (show $ countQuadtree full_tree))

    putStrLn "---------"
    let find_items = findQuadtreeItems full_tree (intersectBoxes Box { box_x1 = 25, box_y1 = 25, box_x2 = 75, box_y2 = 75 })

    print find_items

    let find_html = intercalate "\n" [renderBoxToHtml (quadtreeItemBox item) "rgb(0, 255, 0)" | item <- find_items]


    writeFile "view.html" $ (renderQuadtreeToHtml full_tree) ++ find_html