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