data-spacepart-20090126.0: test/QuadTreeVisualize.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import Data.QuadTree

import Math.Geometry

import Render ( init_display
              , new_viewer
              , view_rendering
              )

import Control.Monad

import Data.Maybe ( maybe )

import Graphics.Rendering.OpenGL as GL
import Graphics.UI.GLUT

import System.Random.Mersenne
import System.Random.Utils

q :: QuadTree Boundary = empty
e0 = Boundary (1.0, 1.0) 2.0
e1 = Boundary (0.0, 0.0) 0.5

main = do 
    (viewer, _) <- new_viewer
    let q' = insert e0 q
    let q'' = insert e1 q'
    gen <- newMTGen Nothing
    (rq, gen) <- random_quadtree gen q 2000
    view_quadtree viewer gen rq
    return ()

random_quadtree gen q 0 = return (q, gen)
random_quadtree gen q n = do
    x :: Double <- randomRange (-10.0) 10.0 gen
    y :: Double <- randomRange (-10.0) 10.0 gen
    s :: Double <- randomRange 0.001 1.0 gen
    let e = Boundary (x, y) s
    let q' = insert e q
    random_quadtree gen q' (n - 1)
    
view_quadtree viewer gen q = do
    view_rendering viewer $ display_quadtree gen q
    mainLoop

display_quadtree gen q@(QuadTree _ (Boundary (bx, by) bsize) _) = do
    clearColor $= Color4 1.0 1.0 1.0 0.0
    clear [ColorBuffer]
    matrixMode $= Modelview 0
    loadIdentity
    -- First set the display to have the extents (0,0) and (1,1)
    translate $ Vector3 (-1.0 :: Double) (-1.0) 0.0
    scale (2.0 :: Double) 2.0 0.0
    -- Scale the entire quadtree to the display.
    scale (1.0 / bsize) (1.0 / bsize) 1.0
    translate $ Vector3 (-bx) (-by) 0.0
    mondrian_quadtree gen q
    lineWidth $= 2.0
    maybe_outline_quadtree gen q
    flush

outline_quadtree q = do
    color $ Color3 (0.0 :: Float) 0.0 0.0
    polygonMode $= (Line, Line)
    renderPrimitive Quads $ outline_quadtree' q
    where 
        outline_quadtree' (QuadTree _ b (cq0, cq1, cq2, cq3)) = do
            mapM_ (maybe (return ()) $ \cq -> outline_quadtree' cq) [cq0, cq1, cq2, cq3]
            render_boundary b

maybe_outline_quadtree gen q = do
    color $ Color3 (0.0 :: Float) 0.0 0.0
    polygonMode $= (Line, Line)
    renderPrimitive Lines $ outline_quadtree' q
    where 
        outline_quadtree' (QuadTree _ b (cq0, cq1, cq2, cq3)) = do
            mapM_ (maybe (return ()) $ \cq -> outline_quadtree' cq) [cq0, cq1, cq2, cq3]
            mapM_ maybe_render_edge (boundary_edges b)
        maybe_render_edge ((x0,y0), (x1,y1)) = do
            p <- flip randomElement gen $ True : replicate 6 False
            if p then vertex (Vertex2 x0 y0) >> vertex (Vertex2 x1 y1)
                 else return ()

outline_elements q = do
    color $ Color3 (1.0 :: Float) 0.0 0.0
    polygonMode $= (Line, Line)
    renderPrimitive Quads $ outline_elements' q
    where
        outline_elements' (QuadTree bs _ (cq0, cq1, cq2, cq3)) = do
            mapM_ (maybe (return ()) $ \cq -> outline_elements' cq) [cq0, cq1, cq2, cq3]
            mapM_ render_boundary bs

mondrian_quadtree gen q = do
    polygonMode $= (Fill, Line)
    renderPrimitive Quads $ mondrian_quadtree' gen q
    where
        mondrian_quadtree' gen (QuadTree bs bounds (cq0, cq1, cq2, cq3)) = do
            p <- flip randomElement gen $ True : replicate 2 False
            r :: Double <- randomRange 0.0 1.0 gen
            g :: Double <- randomRange 0.0 1.0 gen
            b :: Double <- randomRange 0.0 1.0 gen
            if p
                then color $ Color3 r g b
                else color $ Color3 (1.0 :: Double) 1.0 1.0
            render_boundary bounds
            mapM_ (maybe (return ()) $ \cq -> mondrian_quadtree' gen cq) [cq0, cq1, cq2, cq3]

random_color_gen gen = sequence $ repeat $ do
    r :: Double <- randomRange 0.0 1.0 gen
    g :: Double <- randomRange 0.0 1.0 gen
    b :: Double <- randomRange 0.0 1.0 gen
    return $ Color3 r g b

render_boundary (Boundary (x,y) size) = do
    vertex $ Vertex2 x y
    vertex $ Vertex2 (x + size) y
    vertex $ Vertex2 (x + size) (y + size)
    vertex $ Vertex2 x (y + size)