> module Quadtrees where
> import LibXML(vacio,gen,genAs)

> data Color = RGB Int Int Int
>   deriving Show

> data QT = B Color
>         | D QT QT QT QT
>   deriving Show

> rojo, verde, ej :: QT
> rojo  = B (RGB 255 0 0)
> verde = B (RGB 0 255 0)
> ej    = D rojo verde verde rojo 

> type Punto = (Int,Int)
> type Dim = (Punto,Int)

> verqt :: QT -> IO ()
> verqt q = writeFile "qtree.svg" 
>          (gen "svg" (ver ((0,0),512) q))

> ver :: Dim -> QT  -> String
> ver ((x,y),d) (B c) = 
>   rect (x,y) (x+d+1,y+d+1) c 

> ver ((x,y),d) (D ul ur dl dr) = 
>   let d2 = d `div` 2
>  in 
>   if d <= 0 then ""
>   else ver ((x,y),d2)       ul ++
>        ver ((x+d2,y),d2)    ur ++
>        ver ((x,y+d2),d2)    dl ++
>        ver ((x+d2,y+d2),d2) dr

> rect :: Punto -> Punto -> Color -> String
> rect (x,y) (x',y') (RGB r g b) = 
>   vacio "rect" [("x",show x),("y",show y),
>                 ("height",show (abs (x - x'))),
>                 ("width",show (abs (y - y'))),
>                 ("fill", "rgb("++ show r ++","++
>                                   show g ++","++
>                                   show b ++")"),
>  		  ("stroke-width","0")]

> module Octrees where

> data Color = RGB Float Float Float
>   deriving Show

> data OT = Vacio
>         | Cubo   Color
>         | Esfera Color
>         | D OT OT OT OT OT OT OT OT
>  deriving Show

Algunos ejemplos:

> r = Cubo (RGB 1 0 0)
> g = Cubo (RGB 0 1 0)
> s = Esfera (RGB 0 0 1)
> v = Vacio
> ej = D r v v r v g s v

> w :: OT -> IO ()
> w ot = writeFile "e.wrl" 
>     (cabecera ++ 
>      viewPoint ++ 
>      background ++ 
>      verOT ((0,0,0),64) ot)

> type Point3D = (Float,Float,Float)
> type Dim = (Point3D,Float)

> verOT :: Dim -> OT -> String
> verOT _ Vacio          = ""
> verOT (p,d) (Cubo c)   = putBox p c (d,d,d) 
> verOT (p,d) (Esfera c) = putSphere p c (d / 2) 
> verOT ((x,y,z),d) (D c1 c2 c3 c4 c5 c6 c7 c8) = 
>  let d2 = d / 2 
>      d4 = d / 4
>  in if d <= 1 then ""
>     else verOT ((x-d4,y+d4,z+d4),d2) c1 ++
>          verOT ((x+d4,y+d4,z+d4),d2) c2 ++
>          verOT ((x-d4,y-d4,z+d4),d2) c3 ++
>          verOT ((x+d4,y-d4,z+d4),d2) c4 ++
>          verOT ((x-d4,y+d4,z-d4),d2) c5 ++
>          verOT ((x+d4,y+d4,z-d4),d2) c6 ++
>          verOT ((x-d4,y-d4,z-d4),d2) c7 ++
>          verOT ((x+d4,y-d4,z-d4),d2) c8  

> cabecera = 
>  "#VRML V2.0 utf8\n\n" 

> viewPoint = "Viewpoint { "++
>  "         description \"Octrees\" \n" ++
>  "         orientation 0 0 1 0 \n" ++ 
>  "         position 0 0.2 350 \n" ++ " } \n"

> background = 
>   "Background { skyColor [ 0 0.2 0.7, 0 0.5 1, 1 1 1 ] }"

> putBox p (RGB r g b) = translate p . 
>                        color (r,g,b) . 
>                        box

> putSphere :: Point3D -> Color -> Float -> String
> putSphere p (RGB r g b) = translate p . 
>                           color (r,g,b) . 
>                           sphere 

> box (sx,sy,sz) = "geometry Box " ++ llaves ("size " ++ sh3 (sx,sy,sz))
> sphere r = "geometry Sphere " ++ llaves ("radius " ++ show r)

> translate (x,y,z) s = 
>   "Transform" ++ llaves ("translation " ++ sh3 (x,y,z) ++ "\n" ++
>                           "children [" ++ s ++ " ]")

> color (r,g,b) s = "Shape" ++ 
>                   llaves (s ++ "\nappearance Appearance " ++ 
>  	    	    llaves ("material Material " ++
>                   llaves ("diffuseColor " ++ sh3 (r,g,b)))) 

> llaves x = " { " ++ x ++ " } "

> sh3 (x,y,z) = show x ++ " " ++
>               show y ++ " " ++
>               show z ++ " "