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 evaluation engine. 17 - 18 -} 19 20 module Csg(calc) where 21 22 import Matrix 23 import Types 24 import Interval 25 26 #if __HASKELL1__ < 5 27 #define realToFrac fromRealFrac 28 #endif 29 30 -- no is returned when there is "no" change to the csg. 31 no = error ("Evaluated dead csg.") 32 33 calc :: Csg -> Calc 34 35 calc (Func f) rgb xyz = f rgb xyz 36 37 calc (Matrix a mat) rgb xyz 38 = (ans,newc,newr,prune) 39 where 40 newc = if prune then (if b then newc' else newc'') else (no) 41 (newc',b) = if prune then (reduceM newc'' mat) else (no) 42 xyz' = mat4x1 mat xyz 43 (ans,newc'',newr,prune) = calc a rgb xyz' 44 45 calc (Object X) rgb (x,y,z) = (x,no,rgb,False) 46 calc (Object Y) rgb (x,y,z) = (y,no,rgb,False) 47 calc (Object Z) rgb (x,y,z) = (z,no,rgb,False) 48 49 calc (Object (Plane a b c d)) rgb xyz 50 = (ans,(no),rgb,False) 51 where 52 ans = dorow (a,b,c,d) xyz 53 54 calc (Object (Sphere a b c r)) rgb xyz 55 = (ans,newc,rgb,True) 56 where 57 (ans,_,_,_) = calc newc rgb xyz 58 newc = Func f 59 f rgb zyx = (sphere zyx,no,rgb,False) 60 sphere :: (R3 BI) -> BI 61 sphere (x,y,z) = sqr (x-a') + sqr (y-b') + sqr (z-c') - sqr r' 62 a' = realToFrac a ; b' = realToFrac b ; c' = realToFrac c 63 r' = realToFrac r 64 65 calc (Object (Cube a b c r)) rgb xyz 66 = (ans,newc',rgb,bool) 67 where 68 newc'' = if bool then newc else newc' 69 (ans,newc,_,bool) = calc newc' rgb xyz 70 newc' = Inter xx (Inter yy zz) 71 xx = Inter x1 x2 72 yy = Inter y1 y2 73 zz = Inter z1 z2 74 x1 = Object (Plane ( 1) 0 0 (-(a+r))) 75 y1 = Object (Plane 0 ( 1) 0 (-(b+r))) 76 z1 = Object (Plane 0 0 ( 1) (-(c+r))) 77 x2 = Object (Plane (-1) 0 0 ( (a-r))) 78 y2 = Object (Plane 0 (-1) 0 ( (b-r))) 79 z2 = Object (Plane 0 0 (-1) ( (c-r))) 80 81 calc (Union a b) rgb xyz 82 = (min an1 an2,newc,newr,bool) 83 where 84 (an1,c1,rgb1,b1) = calc a rgb xyz 85 (an2,c2,rgb2,b2) = calc b rgb xyz 86 bool = b1 || b2 87 ca = if b1 then c1 else a 88 cb = if b2 then c2 else b 89 newr | an1 < an2 = rgb1 90 | an1 > an2 = rgb2 91 | otherwise = rgb 92 newc | an1 < an2 = ca 93 | an1 > an2 = cb 94 | not bool = (no) 95 | otherwise = Union ca cb 96 97 calc (Inter a b) rgb xyz 98 = (max an1 an2,newc,newr,bool) 99 where 100 (an1,c1,rgb1,b1) = calc a rgb xyz 101 (an2,c2,rgb2,b2) = calc b rgb xyz 102 bool = b1 || b2 103 ca = if b1 then c1 else a 104 cb = if b2 then c2 else b 105 newr | an1 > an2 = rgb1 106 | an1 < an2 = rgb2 107 | otherwise = rgb 108 newc | an1 > an2 = ca 109 | an1 < an2 = cb 110 | not bool = (no) 111 | otherwise = Inter ca cb 112 113 calc (Comp a) rgb xyz 114 = (ans,newc'',newr,True) 115 where 116 (ans,newc,newr,b) = calc newc' rgb xyz 117 newc'' = if b then newc else newc' 118 newc' = Matrix a mat 119 mat = (m1,m2,m3) 120 m1 = (-1, 0, 0, 0) 121 m2 = ( 0,-1, 0, 0) 122 m3 = ( 0, 0,-1, 0) 123 124 calc (Colour c a) rgb xyz 125 = (ans,newc,c,bool) 126 where 127 newc = if bool then (Colour c newc') else (no) 128 (ans,newc',_,bool) = calc a c xyz 129 130 calc (Sub a b) rgb xyz 131 = (ans,newc'',newr,True) 132 where 133 newc' = (a `Inter` (Comp b)) 134 newc'' = if bool then newc else newc' 135 (ans,newc,newr,bool) = calc newc' rgb xyz 136 137 calc (Geom a (Trans h w d)) rgb xyz 138 = (ans,newc'',newr,True) 139 where 140 (ans,newc,newr,b) = calc newc' rgb xyz 141 newc'' = if b then newc else newc' 142 newc' = Matrix a mat 143 mat = (m1,m2,m3) 144 m1 = ( 1, 0, 0, h) 145 m2 = ( 0, 1, 0, w) 146 m3 = ( 0, 0, 1, d) 147 148 calc (Geom a (Scale h w d)) rgb xyz 149 = (ans,newc'',newr,True) 150 where 151 (ans,newc,newr,b) = calc newc' rgb xyz 152 newc'' = if b then newc else newc' 153 newc' = Matrix a mat 154 mat = (m1,m2,m3) 155 m1 = ( h, 0, 0, 0) 156 m2 = ( 0, w, 0, 0) 157 m3 = ( 0, 0, d, 0) 158 159 calc (Geom a (RotX rad)) rgb xyz 160 = (ans,newc'',newr,True) 161 where 162 (ans,newc,newr,b) = calc newc' rgb xyz 163 newc'' = if b then newc else newc' 164 newc' = Matrix a mat 165 mat = (m1,m2,m3) 166 c = cos rad 167 s = sin rad 168 m1 = ( 1, 0, 0, 0) 169 m2 = ( 0, c,-s, 0) 170 m3 = ( 0, s, c, 0) 171 172 calc (Geom a (RotY rad)) rgb xyz 173 = (ans,newc'',newr,True) 174 where 175 (ans,newc,newr,b) = calc newc' rgb xyz 176 newc'' = if b then newc else newc' 177 newc' = Matrix a mat 178 mat = (m1,m2,m3) 179 c = cos rad 180 s = sin rad 181 m1 = ( c, 0, s, 0) 182 m2 = ( 0, 1, 0, 0) 183 m3 = (-s, 0, c, 0) 184 185 calc (Geom a (RotZ rad)) rgb xyz 186 = (ans,newc'',newr,True) 187 where 188 (ans,newc,newr,b) = calc newc' rgb xyz 189 newc'' = if b then newc else newc' 190 newc' = Matrix a mat 191 mat = (m1,m2,m3) 192 c = cos rad 193 s = sin rad 194 m1 = ( c, s, 0, 0) 195 m2 = (-s, c, 0, 0) 196 m3 = ( 0, 0, 1, 0) 197 198 199 -- conflate matrices together and into planes planes... 200 reduceM (Object X) mata 201 = case (mat1x4 (1,0,0,0) mata) of 202 (x,y,z,w) -> (Object (Plane x y z w),True) 203 reduceM (Object Y) mata 204 = case (mat1x4 (0,1,0,0) mata) of 205 (x,y,z,w) -> (Object (Plane x y z w),True) 206 reduceM (Object Z) mata 207 = case (mat1x4 (0,0,1,0) mata) of 208 (x,y,z,w) -> (Object (Plane x y z w),True) 209 reduceM (Object (Plane a b c d)) mata 210 = case (mat1x4 (a,b,c,d) mata) of 211 (x,y,z,w) -> (Object (Plane x y z w),True) 212 reduceM (Matrix b matb) mata 213 = case (mat4x4 mata matb) of 214 matc -> (Matrix b matc,True) 215 reduceM _ _ = (no,False) 216 217 218