1 module BSPT 2 3 4 5 6 ( BSPT(..),Status(..),Point,Region,Line, 7 Face,Faces,buildBSPT,bsp',bsp'',mkCell, partFaces, 8 scanLine,countLeaves,classifyPoint,area, 9 foldBSPT) 10 11 where 12 import EuclidGMS ( Location(..),Partition,Region, 13 mkPart,getPart,newRegion,location,renderBorder, 14 bisect,toBack,findVertices,flip_YORK, 15 Point(..),Line,Face(..),Faces,Halfspace(..), 16 space,convert,triangleArea,Segment ) 17 import GeomNum 18 import Stdlib (mapcat,const3) 19 import Libfuns 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 data BSPT = Cell Status Region Numb | 42 BSP Partition (Faces,Region) BSPT BSPT -- deriving (Text) 43 44 45 46 47 48 data Status = In | Out | On deriving (Eq,Show{-was:Text-}) 49 50 51 52 53 54 type Partitioning = (Faces,Faces,Faces) 55 56 57 58 59 60 61 62 buildBSPT :: Faces -> BSPT 63 buildBSPT = buildBSPTAux Out renderBorder 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 buildBSPTAux :: Status -> Region -> Faces -> BSPT 80 buildBSPTAux status region [] = mkCell status region 81 buildBSPTAux _ region faces = par right (seq left (BSP partition (coin,region) left right)) 82 where 83 left = buildBSPTAux In (newRegion region partition) rear 84 right = buildBSPTAux Out (newRegion region (flip_YORK partition)) fore 85 (rear,coin,fore) = partFaces part faces 86 partition = mkPart region part 87 part = heuristic faces 88 89 90 91 92 93 94 bsp' :: Partition -> (Faces,Region) -> BSPT -> BSPT -> BSPT 95 bsp' part (faces,region) (Cell x _ a) (Cell y _ b) | x==y = Cell x region (a+b) 96 bsp' part nodeInfo left right = BSP part nodeInfo left right 97 98 99 100 101 102 103 104 105 106 107 108 bsp'' :: Partition -> (Faces, Region) -> BSPT -> BSPT -> BSPT 109 bsp'' part (faces,region) left right 110 = if newfaces==[] 111 then simplify part region left right 112 else BSP part (newfaces,region) left right 113 where 114 newfaces = updateFaces left right faces 115 116 117 118 119 120 simplify :: Partition -> Region -> BSPT -> BSPT -> BSPT 121 simplify _ region (Cell _ _ _) (BSP part (faces,_) left right) 122 = BSP (mkPart region (getPart part)) (faces,region) left right 123 simplify _ region (BSP part (faces,_) left right) (Cell _ _ _) 124 = BSP (mkPart region (getPart part)) (faces,region) left right 125 simplify part region tree1 tree2 = bsp' part ([],region) tree1 tree2 126 127 128 129 130 mkCell :: Status -> Region -> BSPT 131 mkCell status region = Cell status region (areaRegion region) 132 133 134 135 136 137 138 139 140 141 142 143 144 partFaces :: Line -> Faces -> (Faces,Faces,Faces) 145 partFaces part [] = ([],[],[]) 146 partFaces part (face@(Fc section _):faces) 147 = par rest 148 (case (location part section) of 149 Coincident -> (rear,face:coin,fore) 150 Intersects -> (rearHalf:rear,coin,foreHalf:fore) 151 ToTheRear -> (face:rear,coin,fore) 152 ToTheFore -> (rear,coin,face:fore)) 153 where 154 (rear,coin,fore) = rest 155 rest = partFaces part faces 156 (rearHalf,foreHalf) = bisect face part 157 158 159 160 161 162 163 164 165 166 heuristic :: Faces -> Line 167 heuristic (Fc _ l:_) = l 168 169 170 171 172 173 174 175 176 177 178 179 180 181 updateFaces :: BSPT -> BSPT -> Faces -> Faces 182 updateFaces left right = mapcat (rubout right).classifyFace left 183 184 185 186 187 188 189 190 classifyFace :: BSPT -> Faces -> [(Face,Status)] 191 classifyFace tree = mapcat (segments tagStatus tree) 192 where 193 tagStatus x face = [(face,x)] 194 195 196 197 198 199 200 rubout :: BSPT -> (Face,Status) -> Faces 201 rubout tree (face,x) = segments (erase x) tree face 202 where erase x y face | x==y = [] 203 | otherwise = [face] 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 segments :: (Status->Face->[a]) -> BSPT -> Face -> [a] 219 segments cellop (Cell status _ _) face = cellop status face 220 segments cellop (BSP part@(Fc _ p) _ left right) face@(Fc fs _) 221 = case (location p fs) of 222 Coincident -> cellop In face 223 Intersects -> segments cellop left leftside ++ 224 segments cellop right rightside 225 ToTheRear -> segments cellop left face 226 ToTheFore -> segments cellop right face 227 where 228 (leftside,rightside) = bisect face p 229 230 231 232 233 234 235 scanLine :: BSPT -> Face -> Faces 236 scanLine = segments filterInside 237 where 238 filterInside In face = [face] 239 filterInside Out _ = [] 240 241 242 243 244 245 246 foldBSPT :: (Status->Region->Numb->a)->(Partition->(Faces,Region)->a->a->a)->BSPT->a 247 foldBSPT cellop nodeop (Cell x r a) = cellop x r a 248 foldBSPT cellop nodeop (BSP part nodeinfo left right) 249 = nodeop part nodeinfo left' right' 250 where 251 left' = f left 252 right' = f right 253 f = foldBSPT cellop nodeop 254 255 256 257 258 259 260 countLeaves :: BSPT -> Int 261 countLeaves = foldBSPT (const3 1) plus 262 where 263 plus _ _ = (+) 264 265 266 267 268 269 area :: BSPT -> Numb 270 area = foldBSPT sumInRegions plus 271 where 272 sumInRegions In _ a = a 273 sumInRegions _ _ _ = 0 274 plus _ _ = (+) 275 276 277 278 areaRegion :: Region -> Numb 279 areaRegion = sum.map triangleArea.triangles.findVertices 280 281 282 283 triangles :: [Point] -> [[Point]] 284 triangles [p1,p2] = [] 285 triangles [p1,p2,p3] = [[p1,p2,p3]] 286 triangles (p1:p2:ps) = if left/=[] && right /=[] then 287 triangles (p1:p2:left) ++ triangles (p1:p2:right) 288 else triangles (p1:ps++[p2]) 289 where 290 (left,right) = partPoints (convert p1 p2) ps 291 292 293 294 295 296 partPoints :: Line -> [Point] -> ([Point],[Point]) 297 partPoints eqn [] = ([],[]) 298 partPoints eqn (p:pts) = if toBack p eqn 299 then (p:left,right) 300 else (left,p:right) 301 where 302 (left,right) = partPoints eqn pts 303 304 305 306 307 classifyPoint :: Point -> BSPT -> Status 308 classifyPoint pt = foldBSPT status (deter pt) 309 where 310 status s _ _ = s 311 deter pt (Fc _ part) _ = deter' (space part pt) 312 where 313 deter' Fore _ x = x 314 deter' Rear x _ = x 315 deter' Coin x y | x==y = x -- was: At (no such thing) 316 | otherwise = On