sordina/quad.hs

## quad.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

import System.Random
import Data.Default
import Data.Maybe
import Data.Char
import Data.Monoid
import Text.InterpolatedString.Perl6

data QTree a = Q { origin   :: Coord
                 , children :: [(Coord, a)]
                 , quarties :: ( Maybe (QTree a)
                               , Maybe (QTree a)
                               , Maybe (QTree a)
                               , Maybe (QTree a)) } deriving Show

data Opts = O { capacity :: Int }

instance Default Opts where def = O 23

newtype Picture = P { prays :: [(String, (Coord,Coord))] }

instance Monoid Picture
  where mempty                = P []
        mappend (P xs) (P ys) = P (xs ++ ys)

type Coord = (Double, Double)

-- Test Stuff

main :: IO ()
main = do
  g1 <- newStdGen
  g2 <- newStdGen
  let ps = zip (randomRs (-1,1) g1) (randomRs (-1,1) g2)
      t  = foldr (insertCoord def) empty (take 2500 ps)
  putStrLn (draw (paint t))

line :: String -> Coord -> Coord -> Picture
line c c1 c2 = P [(c, (c1, c2))]

paint :: QTree a -> Picture
paint t = rays <> subs <> chlds
  where c       = children t
        ql      = qList    t
        o       = origin   t
        rays    = mconcat $ map (line "black"  o . fst) c
        chlds   = mconcat $ map (line "orange" o . origin) ql
        subs    = mconcat $ map paint ql

insertCoord :: Opts -> Coord -> QTree Coord -> QTree Coord
insertCoord o c t = insert o c c t

draw :: Picture -> String
draw p = dropWhile isSpace [qq|
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<html>
  <head>
    <title>QuadTree</title>
  </head>
  <body>
    <div>
      <svg width="900px" height="600px" viewBox="$minx $miny $dx $dy" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
        $paths
      </svg>
      <script>
        var interval = null;

        function render() \{
          if(interval) \{ clearInterval( interval ) };
          var n = n = document.getElementsByTagNameNS("http://www.w3.org/2000/svg","path");
          var i = 0;
          for(var j = 0; j < n.length; j++) \{n[j].style.display = 'none'};
          interval = setInterval(function()\{ if(! n[i]) \{ clearInterval(interval); return}; n[i].style.display = 'block'; i++ }, 1);
          return false;
        }
      </script>
    </div>
    <p> <button onclick="render()">Render</button> </p>
    <p> Code: <a href="https://gist.github.com/sordina/8763910">GitHub</a> </p>
    <p> Implements a simple custom QuadTree algorithm, where the origin of the
      sub-tree is determined by the average of the points owned by that tree when
      the maximum capacity is reached. </p>
  </body>
</html>
|]
  where l = p2l $ prays p
        minx = (minimum $ map fst l) - 0.1
        miny = (minimum $ map snd l) - 0.1
        maxx = (maximum $ map fst l) + 0.1
        maxy = (maximum $ map snd l) + 0.1
        dx   = maxx - minx
        dy   = maxy - miny
        paths = unlines $ map drawLine (prays p)

drawLine :: (String,(Coord,Coord)) -> String
drawLine (c,((x0,y0),(x1,y1))) = [qq| <path stroke="$c" fill="none" stroke-width="0.002" d="M{x0},{y0} {x1},{y1}" /> |]

p2l :: [(c,(a,a))] -> [a]
p2l l = map (fst.snd) l ++ map (snd.snd) l

-- Implementation Stuff

search :: Coord -> QTree a -> [a]
search = undefined

qList :: QTree a -> [QTree a]
qList t = let (a,b,c,d) = quarties t in catMaybes [a,b,c,d]

empty :: QTree a
empty = Q (0,0) [] (Nothing, Nothing, Nothing, Nothing)

insert :: Opts -> Coord -> a -> QTree a -> QTree a
insert o c a t | available o t = insertChild     c a t
               | otherwise     = insertSubtree o c a t

available :: Opts -> QTree a -> Bool
available opts (Q _ cs _) = length cs < capacity opts

insertChild :: Coord -> a -> QTree a -> QTree a
insertChild c a (Q o cs t) = Q o ((c,a):cs) t

insertSubtree :: Opts -> Coord -> a -> QTree a -> QTree a
insertSubtree o xy@(x,y) a t = modifyQuartile xg yg alteration t
  where
  xg                  = x >= ox
  yg                  = y >= oy
  (ox,oy)             = origin t
  alteration Nothing  = Q (averageQuartile xg yg t) [(xy,a)] (Nothing, Nothing, Nothing, Nothing)
  alteration (Just n) = insert o xy a n

averageQuartile :: Bool -> Bool -> QTree a -> Coord
averageQuartile x y t = average filtered
  where
  (ox, oy)  = origin t
  f (px,py) = ((px >= ox) == x) && ((py >= oy) == y)
  filtered  = filter f (map fst (children t))

modifyQuartile :: Bool -> Bool -> (Maybe (QTree a) -> QTree a) -> QTree a -> QTree a
modifyQuartile False False f (Q o cs (a, b, c, d)) = Q o cs (Just (f a),         b,          c,         d)
modifyQuartile False True  f (Q o cs (a, b, c, d)) = Q o cs (a,          Just (f b),         c,         d)
modifyQuartile True  False f (Q o cs (a, b, c, d)) = Q o cs (a,                  b,  Just (f c),        d)
modifyQuartile True  True  f (Q o cs (a, b, c, d)) = Q o cs (a,                  b,          c, Just (f d))

average :: (Fractional a, Fractional b) => [(a,b)] -> (a,b)
average [] = (0,0)
average l  = (mean (map fst l), mean (map snd l))

mean :: (Fractional a) => [a] -> a
mean l = sum l / fromIntegral (length l)
	{-# LANGUAGE OverloadedStrings #-}
	{-# LANGUAGE TemplateHaskell #-}
	{-# LANGUAGE QuasiQuotes #-}

	import System.Random
	import Data.Default
	import Data.Maybe
	import Data.Char
	import Data.Monoid
	import Text.InterpolatedString.Perl6

	data QTree a = Q { origin :: Coord
	, children :: [(Coord, a)]
	, quarties :: ( Maybe (QTree a)
	, Maybe (QTree a)
	, Maybe (QTree a)
	, Maybe (QTree a)) } deriving Show

	data Opts = O { capacity :: Int }

	instance Default Opts where def = O 23

	newtype Picture = P { prays :: [(String, (Coord,Coord))] }

	instance Monoid Picture
	where mempty = P []
	mappend (P xs) (P ys) = P (xs ++ ys)

	type Coord = (Double, Double)

	-- Test Stuff

	main :: IO ()
	main = do
	g1 <- newStdGen
	g2 <- newStdGen
	let ps = zip (randomRs (-1,1) g1) (randomRs (-1,1) g2)
	t = foldr (insertCoord def) empty (take 2500 ps)
	putStrLn (draw (paint t))

	line :: String -> Coord -> Coord -> Picture
	line c c1 c2 = P [(c, (c1, c2))]

	paint :: QTree a -> Picture
	paint t = rays <> subs <> chlds
	where c = children t
	ql = qList t
	o = origin t
	rays = mconcat $ map (line "black" o . fst) c
	chlds = mconcat $ map (line "orange" o . origin) ql
	subs = mconcat $ map paint ql

	insertCoord :: Opts -> Coord -> QTree Coord -> QTree Coord
	insertCoord o c t = insert o c c t

	draw :: Picture -> String
	draw p = dropWhile isSpace [qq\|
	<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
	<html>
	<head>
	<title>QuadTree</title>
	</head>
	<body>
	<div>
	<svg width="900px" height="600px" viewBox="$minx $miny $dx $dy" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
	$paths
	</svg>
	<script>
	var interval = null;

	function render() \{
	if(interval) \{ clearInterval( interval ) };
	var n = n = document.getElementsByTagNameNS("http://www.w3.org/2000/svg","path");
	var i = 0;
	for(var j = 0; j < n.length; j++) \{n[j].style.display = 'none'};
	interval = setInterval(function()\{ if(! n[i]) \{ clearInterval(interval); return}; n[i].style.display = 'block'; i++ }, 1);
	return false;
	}
	</script>
	</div>
	<p> <button onclick="render()">Render</button> </p>
	<p> Code: <a href="https://gist.github.com/sordina/8763910">GitHub</a> </p>
	<p> Implements a simple custom QuadTree algorithm, where the origin of the
	sub-tree is determined by the average of the points owned by that tree when
	the maximum capacity is reached. </p>
	</body>
	</html>
	\|]
	where l = p2l $ prays p
	minx = (minimum $ map fst l) - 0.1
	miny = (minimum $ map snd l) - 0.1
	maxx = (maximum $ map fst l) + 0.1
	maxy = (maximum $ map snd l) + 0.1
	dx = maxx - minx
	dy = maxy - miny
	paths = unlines $ map drawLine (prays p)

	drawLine :: (String,(Coord,Coord)) -> String
	drawLine (c,((x0,y0),(x1,y1))) = [qq\| <path stroke="$c" fill="none" stroke-width="0.002" d="M{x0},{y0} {x1},{y1}" /> \|]

	p2l :: [(c,(a,a))] -> [a]
	p2l l = map (fst.snd) l ++ map (snd.snd) l

	-- Implementation Stuff

	search :: Coord -> QTree a -> [a]
	search = undefined

	qList :: QTree a -> [QTree a]
	qList t = let (a,b,c,d) = quarties t in catMaybes [a,b,c,d]

	empty :: QTree a
	empty = Q (0,0) [] (Nothing, Nothing, Nothing, Nothing)

	insert :: Opts -> Coord -> a -> QTree a -> QTree a
	insert o c a t \| available o t = insertChild c a t
	\| otherwise = insertSubtree o c a t

	available :: Opts -> QTree a -> Bool
	available opts (Q _ cs _) = length cs < capacity opts

	insertChild :: Coord -> a -> QTree a -> QTree a
	insertChild c a (Q o cs t) = Q o ((c,a):cs) t

	insertSubtree :: Opts -> Coord -> a -> QTree a -> QTree a
	insertSubtree o xy@(x,y) a t = modifyQuartile xg yg alteration t
	where
	xg = x >= ox
	yg = y >= oy
	(ox,oy) = origin t
	alteration Nothing = Q (averageQuartile xg yg t) [(xy,a)] (Nothing, Nothing, Nothing, Nothing)
	alteration (Just n) = insert o xy a n

	averageQuartile :: Bool -> Bool -> QTree a -> Coord
	averageQuartile x y t = average filtered
	where
	(ox, oy) = origin t
	f (px,py) = ((px >= ox) == x) && ((py >= oy) == y)
	filtered = filter f (map fst (children t))

	modifyQuartile :: Bool -> Bool -> (Maybe (QTree a) -> QTree a) -> QTree a -> QTree a
	modifyQuartile False False f (Q o cs (a, b, c, d)) = Q o cs (Just (f a), b, c, d)
	modifyQuartile False True f (Q o cs (a, b, c, d)) = Q o cs (a, Just (f b), c, d)
	modifyQuartile True False f (Q o cs (a, b, c, d)) = Q o cs (a, b, Just (f c), d)
	modifyQuartile True True f (Q o cs (a, b, c, d)) = Q o cs (a, b, c, Just (f d))

	average :: (Fractional a, Fractional b) => [(a,b)] -> (a,b)
	average [] = (0,0)
	average l = (mean (map fst l), mean (map snd l))

	mean :: (Fractional a) => [a] -> a
	mean l = sum l / fromIntegral (length l)