> module Pf503 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 ++ " "