module Graphics.Hoodle.Render.Util.HitTest where
import Control.Applicative
import Control.Monad.State
import Data.Strict.Tuple
import Data.Hoodle.Simple
import Data.Hoodle.BBox
import Graphics.Hoodle.Render.Type.HitTest
import Graphics.Hoodle.Render.Type.Item
isPointInBBox :: BBox
-> (Double,Double)
-> Bool
isPointInBBox (BBox (ulx,uly) (lrx,lry)) (x,y)
= ulx <= x && x <= lrx && uly <= y && y <= lry
do2LinesIntersect :: ((Double,Double),(Double,Double))
-> ((Double,Double),(Double,Double))
-> Bool
do2LinesIntersect ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4)) =
(x2xc)*(xcx1)>0 && (x3xc)*(xcx4) >0
where x21 = x2x1
x43 = x4x3
y21 = y2y1
y43 = y4y3
xc = (x21*x43*(y3y1)+y21*x43*x1y43*x21*x3)/(y21*x43y43*x21)
doesLineHitStrk :: ((Double,Double),(Double,Double)) -> Stroke -> Bool
doesLineHitStrk line1 str@(Stroke _t _c _w _d) = test (stroke_data str)
where test [] = False
test ((_:!:_):[]) = False
test ((x0:!:y0):(x:!:y):rest)
= do2LinesIntersect line1 ((x0,y0),(x,y))
|| test ((x:!:y) : rest)
doesLineHitStrk line1 (VWStroke _t _c d) = test d
where test [] = False
test ((_,_,_):[]) = False
test ((x0,y0,_):(x,y,z):rest)
= do2LinesIntersect line1 ((x0,y0),(x,y))
|| test ((x,y,z) : rest)
do2BBoxIntersect :: BBox -> BBox -> Bool
do2BBoxIntersect (BBox (ulx1,uly1) (lrx1,lry1)) (BBox (ulx2,uly2) (lrx2,lry2))
= p1 && p2
where p1 = ulx1 <= ulx2 && ulx2 <= lrx1
|| ulx1 <= lrx2 && lrx2 <= lrx1
|| ulx2 <= ulx1 && ulx1 <= lrx2
|| ulx2 <= lrx1 && lrx1 <= lrx2
p2 = uly1 <= uly2 && uly2 <= lry1
|| uly1 <= lry2 && lry2 <= lry1
|| uly2 <= uly1 && uly1 <= lry2
|| uly2 <= lry1 && lry1 <= lry2
isBBox2InBBox1 :: BBox
-> BBox
-> Bool
isBBox2InBBox1 b1 (BBox (ulx2,uly2) (lrx2,lry2))
= isPointInBBox b1 (ulx2,uly2) && isPointInBBox b1 (lrx2,lry2)
hltFilteredBy_StateT :: (a -> Bool)
-> [a]
-> State Bool (AlterList (NotHitted a) (Hitted a))
hltFilteredBy_StateT test itms = do
let (nhit,rest) = break test itms
(hit,rest') = break (not.test) rest
modify (|| (not.null) hit)
if null rest'
then return (NotHitted nhit :- Hitted hit :- NotHitted [] :- Empty)
else return (NotHitted nhit :- Hitted hit :- hltFilteredBy test rest')
hltFilteredBy :: (a -> Bool)
-> [a]
-> AlterList (NotHitted a) (Hitted a)
hltFilteredBy test is = evalState (hltFilteredBy_StateT test is) False
hltHittedByBBox :: (GetBBoxable a) =>
BBox
-> [a]
-> AlterList (NotHitted a) (Hitted a)
hltHittedByBBox b = hltFilteredBy (do2BBoxIntersect b . getBBox)
hltEmbeddedByBBox :: (GetBBoxable a) =>
BBox
-> [a]
-> AlterList (NotHitted a) (Hitted a)
hltEmbeddedByBBox b = hltFilteredBy (isBBox2InBBox1 b . getBBox)
hltHittedByLineRough :: (GetBBoxable a) =>
((Double,Double),(Double,Double))
-> [a]
-> AlterList (NotHitted a) (Hitted a)
hltHittedByLineRough (p1,p2) = hltFilteredBy boxhittest
where boxhittest s = isPointInBBox (getBBox s) p1
|| isPointInBBox (getBBox s) p2
hltItmsHittedByLine_StateT :: ((Double,Double),(Double,Double))
-> [RItem]
-> State Bool RItemHitted
hltItmsHittedByLine_StateT line = hltFilteredBy_StateT test
where test (RItemStroke strk) = (doesLineHitStrk line . bbxed_content) strk
test _ = False
hltItmsHittedByLineFrmSelected_StateT ::
((Double,Double),(Double,Double))
-> RItemHitted
-> State Bool (AlterList (NotHitted RItem) RItemHitted)
hltItmsHittedByLineFrmSelected_StateT _ Empty
= error "something is wrong, invariant broken"
hltItmsHittedByLineFrmSelected_StateT _ (n:-Empty) = return (n:-Empty)
hltItmsHittedByLineFrmSelected_StateT line (n:-h:-rest) = do
h' <- hltItmsHittedByLine_StateT line (unHitted h)
(n:-) . (h':-) <$> hltItmsHittedByLineFrmSelected_StateT line rest
elimHitted :: (GetBBoxable a) =>
AlterList (NotHitted a) (Hitted a) -> State (Maybe BBox) [a]
elimHitted Empty = error "something wrong in elimHitted"
elimHitted (n:-Empty) = return (unNotHitted n)
elimHitted (n:-h:-rest) = do
bbox <- get
let bbox2 = getTotalBBox (unHitted h)
put (merge bbox bbox2)
return . (unNotHitted n ++) =<< elimHitted rest
merge :: Maybe BBox -> Maybe BBox -> Maybe BBox
merge Nothing Nothing = Nothing
merge Nothing (Just b) = Just b
merge (Just b) Nothing = Just b
merge (Just (BBox (x1,y1) (x2,y2))) (Just (BBox (x3,y3) (x4,y4)))
= Just (BBox (min x1 x3, min y1 y3) (max x2 x4,max y2 y4))
getTotalBBox :: (GetBBoxable a) => [a] -> Maybe BBox
getTotalBBox = foldl f Nothing
where f acc = merge acc . Just . getBBox