1 {- 2 - Fulsom (The Solid Modeller, written in Haskell) 3 - 4 - Copyright 1990,1991,1992,1993 Duncan Sinclair 5 - 6 - Permissiom to use, copy, modify, and distribute this software for any 7 - purpose and without fee is hereby granted, provided that the above 8 - copyright notice and this permission notice appear in all copies, and 9 - that my name not be used in advertising or publicity pertaining to this 10 - software without specific, written prior permission. I makes no 11 - representations about the suitability of this software for any purpose. 12 - It is provided ``as is'' without express or implied warranty. 13 - 14 - Duncan Sinclair 1993. 15 - 16 - Csg to Oct-tree processing. 17 - 18 -} 19 20 module Oct (octcsg) where 21 22 import Csg 23 import Interval 24 import Types 25 import Kolor 26 import Vector 27 28 startx = -2 29 endx = 2 30 31 starty = -2 32 endy = 2 33 34 startz = -2 35 endz = 2 36 37 makeoct :: Csg -> Oct 38 makeoct csg = octer 1 csg xyz 39 where 40 xyz = (x,y,z) 41 x = startx # endx 42 y = starty # endy 43 z = startz # endz 44 45 46 -- octer :: Int -> Csg -> (R3 BI) -> Oct 47 octer nn csg xyz 48 = case (calc csg white xyz) of 49 (res,newc',rgb,new) -> 50 let 51 newc = if new then newc' else csg 52 c = light rgb (calcn newc xyz) 53 (x,y,z) = xyz 54 bhx = bothalf x ; thx = tophalf x 55 bhy = bothalf y ; thy = tophalf y 56 tbz = topbit z ; bhz = bothalf z 57 os = if nn == 1 then osb else osa 58 n1 = nn + 1 59 osa = map (octer n1 newc) 60 [ (bhx,bhy,tbz) , (bhx,bhy,bhz) , 61 (thx,bhy,tbz) , (thx,bhy,bhz) , 62 (bhx,thy,tbz) , (bhx,thy,bhz) , 63 (thx,thy,tbz) , (thx,thy,bhz) ] 64 osb = [(octer n1 newc (bhx,bhy,tbz)) , 65 (octer n1 newc (bhx,bhy,bhz)) , 66 (octer n1 newc (thx,bhy,tbz)) , 67 (octer n1 newc (thx,bhy,bhz)) , 68 (octer n1 newc (bhx,thy,tbz)) , 69 (octer n1 newc (bhx,thy,bhz)) , 70 (octer n1 newc (thx,thy,tbz)) , 71 (octer n1 newc (thx,thy,bhz)) ] 72 in 73 if res < (pt 0) then 74 O_Full c 75 else if res > (pt 0) then 76 O_Empty 77 else 78 O_Sub c os 79 80 {- 81 os = map (octer newc) 82 [ (bhx,bhy,tbz) , (bhx,bhy,bhz) , 83 (thx,bhy,tbz) , (thx,bhy,bhz) , 84 (bhx,thy,tbz) , (bhx,thy,bhz) , 85 (thx,thy,tbz) , (thx,thy,bhz) ] 86 -} 87 88 calcn csg xyz = normalise (makevector f0 f1 f2 f3) 89 where 90 (f0,_,_,_) = calc csg black (mid1 x,mid1 y,mid2 z) 91 (f1,_,_,_) = calc csg black (mid2 x,mid1 y,mid2 z) 92 (f2,_,_,_) = calc csg black (mid1 x,mid2 y,mid2 z) 93 (f3,_,_,_) = calc csg black (mid1 x,mid1 y, up z) 94 (x,y,z) = xyz 95 96 97 pruneoct :: Int -> Oct -> Oct 98 pruneoct 0 (O_Sub c os) = O_Full c 99 pruneoct n (O_Sub c os) = O_Sub c (map (pruneoct (n-1)) os) 100 pruneoct n o = o 101 102 octcsg :: Int -> Csg -> Oct 103 octcsg depth = (pruneoct depth) . makeoct 104 105