1 module Merge 2 3 4 5 (union,intersection,subtract_YORK,complement) 6 7 where 8 9 import BSPT (BSPT(..),Status(..),bsp',bsp'',mkCell,partFaces,foldBSPT) 10 import EuclidGMS (Point,Line,Face(..),Region,Location(..),Partition,Faces, 11 newRegion,getPart,bisect,location,section,flip_YORK, Segment) 12 import Stdlib (mappair) 13 import GeomNum 14 import Libfuns 15 16 -- -------- Type decls ------------------------ 17 18 19 20 21 union :: BSPT -> BSPT -> BSPT 22 union = merge rules 23 where 24 rules :: BSPT -> BSPT -> BSPT 25 rules cell@(Cell In _ _) tree = cell 26 rules cell@(Cell Out _ _) tree = tree 27 rules tree cell@(Cell In _ _) = cell 28 rules tree cell@(Cell Out _ _) = tree 29 30 31 intersection :: BSPT -> BSPT -> BSPT 32 intersection = merge rules 33 where 34 rules :: BSPT -> BSPT -> BSPT 35 rules cell@(Cell In _ _) tree = tree 36 rules cell@(Cell Out _ _) tree = cell 37 rules tree cell@(Cell In _ _) = tree 38 rules tree cell@(Cell Out _ _) = cell 39 40 subtract_YORK :: BSPT -> BSPT -> BSPT 41 subtract_YORK x y = intersection x (complement y) 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 merge :: (BSPT -> BSPT -> BSPT) -> BSPT -> BSPT -> BSPT 58 merge op (Cell x r a) tree = op (Cell x r a) tree 59 merge op tree (Cell x r a) = op tree (Cell x r a) 60 merge op (BSP p nodeinfo left right) tree 61 = bsp'' p nodeinfo left' right' 62 where 63 left'= merge op left rear 64 right'= merge op right fore 65 (rear,fore) = partTree p tree 66 67 68 69 70 71 72 73 74 75 partTree :: Partition -> BSPT -> (BSPT,BSPT) 76 partTree part (Cell x region a) = (mkCell x (newRegion region part), 77 mkCell x (newRegion region (flip_YORK part))) 78 partTree part@(Fc sp p) tree@(BSP (Fc st t) (_,region) _ _) 79 = case (location p st, location t sp) of 80 (Coincident,_) -> if p==t 81 then onParallel part tree 82 else onAntiparallel part tree 83 (ToTheFore,ToTheFore) -> pinPostinPos part tree 84 (ToTheFore,ToTheRear) -> pinNegtinPos part tree 85 (ToTheRear,ToTheFore) -> pinPostinNeg part tree 86 (ToTheRear,ToTheRear) -> pinNegtinNeg part tree 87 (_,_) -> inBoth part tree 88 89 90 91 92 93 94 onParallel :: Partition -> BSPT -> (BSPT,BSPT) 95 onParallel p (BSP t _ rear fore) = (rear,fore) 96 97 onAntiparallel :: Partition -> BSPT -> (BSPT,BSPT) 98 onAntiparallel p (BSP t _ rear fore) = (fore,rear) 99 100 pinPostinNeg :: Partition -> BSPT -> (BSPT,BSPT) 101 pinPostinNeg p (BSP t (faces,region) tRear tFore) 102 = (bsp' t (faces,newRegion region p) tRear tForepRear, 103 tForepFore) 104 where 105 (tForepRear,tForepFore) = partTree p tFore 106 107 pinPostinPos :: Partition -> BSPT -> (BSPT,BSPT) 108 pinPostinPos p (BSP t (faces,region) tRear tFore) 109 = (tForepRear, 110 bsp' t (faces,newRegion region (flip_YORK p)) tRear tForepFore) 111 where 112 (tForepRear,tForepFore) = partTree p tFore 113 114 pinNegtinPos :: Partition -> BSPT -> (BSPT,BSPT) 115 pinNegtinPos p (BSP t (faces,region) tRear tFore) 116 = (tRearpRear, 117 bsp' t (faces,newRegion region (flip_YORK p)) tRearpFore tFore) 118 where 119 (tRearpRear,tRearpFore) = partTree p tRear 120 121 pinNegtinNeg :: Partition -> BSPT -> (BSPT,BSPT) 122 pinNegtinNeg p (BSP t (faces,region) tRear tFore) 123 = (bsp' t (faces,newRegion region p) tRearpRear tFore, 124 tRearpFore) 125 where 126 (tRearpRear,tRearpFore) = partTree p tRear 127 128 inBoth :: Partition -> BSPT -> (BSPT,BSPT) 129 inBoth p (BSP t (faces,region) tRear tFore) 130 = (bsp' tLeft (rearFaces,leftRegion) tRearpRear tForepRear, 131 bsp' tRight (foreFaces,rightRegion) tRearpFore tForepFore) 132 where 133 (tRearpRear,tRearpFore) = partTree pLeft tRear 134 (tForepRear,tForepFore) = partTree pRight tFore 135 (rearFaces,_,foreFaces) = partFaces p' faces 136 (leftRegion,rightRegion) = mappair (newRegion region) (pLeft,pRight) 137 (tLeft,tRight) = bisect t p' 138 (pLeft,pRight) = bisect p (getPart t) 139 p' = getPart p 140 141 142 143 144 145 complement :: BSPT -> BSPT 146 complement = foldBSPT compCell BSP 147 where 148 compCell In = Cell Out 149 compCell Out = Cell In