{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Select -- Copyright : (c) 2011, 2012 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.ModelAction.Select where -- from other package import Control.Category import Control.Lens import Control.Monad import Data.Algorithm.Diff import Data.Foldable (foldl') import qualified Data.IntMap as M import qualified Data.Map as Map import Data.Monoid import Data.Sequence (ViewL(..),viewl,Seq) import Data.Strict.Tuple import Data.Time.Clock import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo.Matrix ( invert, transformPoint ) import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.BBox import Data.Hoodle.Select import Data.Hoodle.Simple hiding (Page,Hoodle) import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Type.HitTest import Graphics.Hoodle.Render.Util import Graphics.Hoodle.Render.Util.HitTest -- from this package import Hoodle.ModelAction.Layer import Hoodle.Type.Alias import Hoodle.Type.Enum import Hoodle.Type.HoodleState import Hoodle.Type.Predefined import Hoodle.Type.PageArrangement import Hoodle.Util import Hoodle.View.Coordinate -- import Prelude hiding ((.),id) -- | data Handle = HandleTL | HandleTR | HandleBL | HandleBR | HandleTM | HandleBM | HandleML | HandleMR deriving (Show) -- | scaleFromToBBox :: BBox -> BBox -> (Double,Double) -> (Double,Double) scaleFromToBBox (BBox (ox1,oy1) (ox2,oy2)) (BBox (nx1,ny1) (nx2,ny2)) (x,y) = let scalex = (nx2-nx1) / (ox2-ox1) scaley = (ny2-ny1) / (oy2-oy1) nx = (x-ox1)*scalex+nx1 ny = (y-oy1)*scaley+ny1 in (nx,ny) -- | isBBoxDeltaSmallerThan :: Double -> PageNum -> CanvasGeometry -> BBox -> BBox -> Bool isBBoxDeltaSmallerThan delta pnum geometry (BBox (x11,y11) (x12,y12)) (BBox (x21,y21) (x22,y22)) = let (x11',y11') = coordtrans (x11,y11) (x12',y12') = coordtrans (x12,y12) (x21',y21') = coordtrans (x21,y21) (x22',y22') = coordtrans (x22,y22) in (x11'-x21' > (-delta) && x11'-x21' < delta) && (y11'-y21' > (-delta) && y11'-y21' < delta) && (x12'-x22' > (-delta) && x12'-x22' < delta) && (y11'-y21' > (-delta) && y12'-y22' < delta) where coordtrans (x,y) = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (x,y)) -- | changeItemBy :: ((Double,Double)->(Double,Double)) -> RItem -> RItem changeItemBy func (RItemStroke strk) = RItemStroke (changeStrokeBy func strk) changeItemBy func (RItemImage img sfc) = RItemImage (changeImageBy func img) sfc changeItemBy func (RItemSVG svg rsvg) = RItemSVG (changeSVGBy func svg) rsvg -- | modify stroke using a function changeStrokeBy :: ((Double,Double)->(Double,Double)) -> StrokeBBox -> StrokeBBox changeStrokeBy func (StrokeBBox (Stroke t c w ds) _bbox) = let change ( x :!: y ) = let (nx,ny) = func (x,y) in nx :!: ny newds = map change ds nstrk = Stroke t c w newds nbbox = bboxFromStroke nstrk in StrokeBBox nstrk nbbox changeStrokeBy func (StrokeBBox (VWStroke t c ds) _bbox) = let change (x,y,z) = let (nx,ny) = func (x,y) in (nx,ny,z) newds = map change ds nstrk = VWStroke t c newds nbbox = bboxFromStroke nstrk in StrokeBBox nstrk nbbox -- | changeImageBy :: ((Double,Double)->(Double,Double)) -> ImageBBox -> ImageBBox changeImageBy func (ImageBBox (Image bstr (x,y) (Dim w h)) _bbox) = let (x1,y1) = func (x,y) (x2,y2) = func (x+w,y+h) nimg = Image bstr (x1,y1) (Dim (x2-x1) (y2-y1)) in mkImageBBox nimg -- | changeSVGBy :: ((Double,Double)->(Double,Double)) -> SVGBBox -> SVGBBox changeSVGBy func (SVGBBox (SVG t c bstr (x,y) (Dim w h)) _bbox) = let (x1,y1) = func (x,y) (x2,y2) = func (x+w,y+h) nsvg = SVG t c bstr (x1,y1) (Dim (x2-x1) (y2-y1)) in mkSVGBBox nsvg -- nbbox = bboxFromImage nimg -- in ImageBBox nimg nbbox -- | rItmsInActiveLyr :: Page SelectMode -> Either [RItem] (TAlterHitted RItem) rItmsInActiveLyr = unTEitherAlterHitted.view (glayers.selectedLayer.gitems) -- | getSelectedItms :: Page SelectMode -> [RItem] getSelectedItms = either (const []) (concatMap unHitted . getB) . rItmsInActiveLyr -- | getSelectedItmsFromHoodleState :: HoodleState -> Maybe [RItem] getSelectedItmsFromHoodleState xstate = case view hoodleModeState xstate of ViewAppendState _ -> Nothing SelectState thdl -> fmap (getSelectedItms.Prelude.snd) (view gselSelected thdl) -- | start a select mode with alter list selection makePageSelectMode :: Page EditMode -- ^ base page -> TAlterHitted RItem -- ^ current selection layer (active layer will be replaced) -> Page SelectMode -- ^ resultant select mode page makePageSelectMode page alist = let (mcurrlayer,npage) = getCurrentLayerOrSet page clyr = maybeError' "makePageSelectMode" mcurrlayer nlyr= GLayer (view gbuffer clyr) (TEitherAlterHitted (Right alist)) in set (glayers.selectedLayer) nlyr (mkHPage npage) -- | get unselected part of page and make an ordinary page deleteSelected :: Page SelectMode -> Page SelectMode deleteSelected tpage = let activelayer = rItmsInActiveLyr tpage buf = view (glayers.selectedLayer.gbuffer) tpage in case activelayer of Left _ -> tpage Right alist -> let leftstrs = concat (getA alist) layer' = GLayer buf . TEitherAlterHitted . Left $ leftstrs in set (glayers.selectedLayer) layer' tpage -- | modify the whole selection using a function changeSelectionBy :: ((Double,Double) -> (Double,Double)) -> Page SelectMode -> Page SelectMode changeSelectionBy func tpage = let activelayer = rItmsInActiveLyr tpage buf = view (glayers.selectedLayer.gbuffer) tpage in case activelayer of Left _ -> tpage Right alist -> let alist' =fmapAL id (Hitted . map (changeItemBy func) . unHitted) alist layer' = GLayer buf . TEitherAlterHitted . Right $ alist' in set (glayers.selectedLayer) layer' tpage -- | special case of offset modification changeSelectionByOffset :: (Double,Double) -> Page SelectMode -> Page SelectMode changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy)) -- | offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy) -- | updateTempHoodleSelect :: Hoodle SelectMode -> Page SelectMode -> Int -> Hoodle SelectMode updateTempHoodleSelect thdl tpage pagenum = let pgs = view gselAll thdl pgs' = M.adjust (const (hPage2RPage tpage)) pagenum pgs in set gselAll pgs' . set gselSelected (Just (pagenum,tpage)) $ thdl -- | updateTempHoodleSelectIO :: Hoodle SelectMode -> Page SelectMode -> Int -> IO (Hoodle SelectMode) updateTempHoodleSelectIO thdl tpage pagenum = do let pgs = view gselAll thdl newpage <- (updatePageBuf.hPage2RPage) tpage let pgs' = M.adjust (const newpage) pagenum pgs return $ set gselAll pgs' . set gselSelected (Just (pagenum,tpage)) $ thdl -- | calculateWholeBBox :: [StrokeBBox] -> Maybe BBox calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. strkbbx_bbx ) -- | hitInSelection :: Page SelectMode -> (Double,Double) -> Bool hitInSelection tpage point = case rItmsInActiveLyr tpage of Left _ -> False Right alist -> let Union bboxall = mconcat . map ( Union . Middle. getBBox ) . takeHitted $ alist in case bboxall of Middle bbox -> isPointInBBox bbox point _ -> False -- | getULBBoxFromSelected :: Page SelectMode -> ULMaybe BBox getULBBoxFromSelected tpage = case rItmsInActiveLyr tpage of Left _ -> Bottom Right alist -> bbox4All . takeHitted $ alist -- | hitInHandle :: Page SelectMode -> (Double,Double) -> Bool hitInHandle tpage point = case getULBBoxFromSelected tpage of Middle bbox -> maybe False (const True) (checkIfHandleGrasped bbox point) _ -> False -- | toggleCutCopyDelete :: UIManager -> Bool -> IO () toggleCutCopyDelete ui b = do agr <- uiManagerGetActionGroups ui >>= \x -> case x of [] -> error "No action group?" y:_ -> return y Just deletea <- actionGroupGetAction agr "DELETEA" Just copya <- actionGroupGetAction agr "COPYA" Just cuta <- actionGroupGetAction agr "CUTA" let copycutdeletea = [copya,cuta,deletea] mapM_ (flip actionSetSensitive b) copycutdeletea -- | togglePaste :: UIManager -> Bool -> IO () togglePaste ui b = do agr <- uiManagerGetActionGroups ui >>= \x -> case x of [] -> error "No action group?" y:_ -> return y Just pastea <- actionGroupGetAction agr "PASTEA" actionSetSensitive pastea b -- | changeStrokeColor :: PenColor -> StrokeBBox -> StrokeBBox changeStrokeColor pcolor str = let Just cname = Map.lookup pcolor penColorNameMap strsmpl = strkbbx_strk str in str { strkbbx_strk = set color cname strsmpl } -- | changeStrokeWidth :: Double -> StrokeBBox -> StrokeBBox changeStrokeWidth pwidth str = let nstrsmpl = case strkbbx_strk str of Stroke t c _w d -> Stroke t c pwidth d VWStroke t c d -> Stroke t c pwidth (map (\(x,y,_z) -> (x:!:y)) d) -- Img b w h -> Img b w h in str { strkbbx_strk = nstrsmpl } -- | changeItemStrokeWidth :: Double -> RItem -> RItem changeItemStrokeWidth pwidth (RItemStroke strk) = RItemStroke (changeStrokeWidth pwidth strk) changeItemStrokeWidth _ r = r -- | changeItemStrokeColor :: PenColor -> RItem -> RItem changeItemStrokeColor pcolor (RItemStroke strk) = RItemStroke (changeStrokeColor pcolor strk) changeItemStrokeColor _ r = r -- | newtype CmpBBox a = CmpBBox { unCmpBBox :: a } -- deriving Show instance (BBoxable a) => Eq (CmpBBox a) where CmpBBox s1 == CmpBBox s2 = getBBox s1 == getBBox s2 -- | isSame :: DI -> Bool isSame B = True isSame _ = False -- | separateFS :: [(DI,a)] -> ([a],[a]) separateFS = foldr f ([],[]) where f (F,x) (fs,ss) = (x:fs,ss) f (S,x) (fs,ss) = (fs,x:ss) f (B,_x) (fs,ss) = (fs,ss) -- | getDiffBBox :: (BBoxable a) => [a] -> [a] -> [(DI,a)] getDiffBBox lst1 lst2 = let nlst1 = fmap CmpBBox lst1 nlst2 = fmap CmpBBox lst2 diffresult = getDiff nlst1 nlst2 in map (\(x,y)->(x,unCmpBBox y)) diffresult -- | checkIfHandleGrasped :: BBox -> (Double,Double) -> Maybe Handle checkIfHandleGrasped (BBox (ulx,uly) (lrx,lry)) (x,y) | isPointInBBox (BBox (ulx-5,uly-5) (ulx+5,uly+5)) (x,y) = Just HandleTL | isPointInBBox (BBox (lrx-5,uly-5) (lrx+5,uly+5)) (x,y) = Just HandleTR | isPointInBBox (BBox (ulx-5,lry-5) (ulx+5,lry+5)) (x,y) = Just HandleBL | isPointInBBox (BBox (lrx-5,lry-5) (lrx+5,lry+5)) (x,y) = Just HandleBR | isPointInBBox (BBox (0.5*(ulx+lrx)-5,uly-5) (0.5*(ulx+lrx)+5,uly+5)) (x,y) = Just HandleTM | isPointInBBox (BBox (0.5*(ulx+lrx)-5,lry-5) (0.5*(ulx+lrx)+5,lry+5)) (x,y) = Just HandleBM | isPointInBBox (BBox (ulx-5,0.5*(uly+lry)-5) (ulx+5,0.5*(uly+lry)+5)) (x,y) = Just HandleML | isPointInBBox (BBox (lrx-5,0.5*(uly+lry)-5) (lrx+5,0.5*(uly+lry)+5)) (x,y) = Just HandleMR | otherwise = Nothing getNewBBoxFromHandlePos :: Handle -> BBox -> (Double,Double) -> BBox getNewBBoxFromHandlePos handle (BBox (ox1,oy1) (ox2,oy2)) (x,y) = case handle of HandleTL -> BBox (x,y) (ox2,oy2) HandleTR -> BBox (ox1,y) (x,oy2) HandleBL -> BBox (x,oy1) (ox2,y) HandleBR -> BBox (ox1,oy1) (x,y) HandleTM -> BBox (ox1,y) (ox2,oy2) HandleBM -> BBox (ox1,oy1) (ox2,y) HandleML -> BBox (x,oy1) (ox2,oy2) HandleMR -> BBox (ox1,oy1) (x,oy2) angleBAC :: (Double,Double) -> (Double,Double) -> (Double,Double) -> Double angleBAC (bx,by) (ax,ay) (cx,cy) = let theta1 | ax==bx && ay>by = pi/2.0 | ax==bx && ay<=by = -pi/2.0 | axby = atan ((ay-by)/(ax-bx)) + pi | axby = pi/2.0 | cx==bx && cy<=by = -pi/2.0 | cxby = atan ((cy-by)/(cx-bx)) +pi | cx pi = dtheta - 2.0*pi | dtheta < (-pi) = dtheta + 2.0*pi | otherwise = dtheta in result wrappingAngle :: Seq (Double,Double) -> (Double,Double) -> Double wrappingAngle lst p = case viewl lst of EmptyL -> 0 x :< xs -> Prelude.snd $ foldl' f (x,0) xs where f (q',theta) q = let theta' = angleBAC p q' q in theta' `seq` (q,theta'+theta) mappingDegree :: Seq (Double,Double) -> (Double,Double) -> Int mappingDegree lst = round . (/(2.0*pi)) . wrappingAngle lst -- | hitLassoPoint :: Seq (Double,Double) -> (Double,Double) -> Bool hitLassoPoint lst = odd . mappingDegree lst -- | hitLassoStroke :: Seq (Double,Double) -> StrokeBBox -> Bool hitLassoStroke lst = all (hitLassoPoint lst) . getXYtuples . strkbbx_strk -- | hitLassoItem :: Seq (Double,Double) -> RItem -> Bool hitLassoItem lst (RItemStroke strk) = hitLassoStroke lst strk hitLassoItem lst (RItemImage img _) = hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) where BBox (x1,y1) (x2,y2) = getBBox img hitLassoItem lst (RItemSVG svg _) = hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) where BBox (x1,y1) (x2,y2) = getBBox svg data TempSelectRender a = TempSelectRender { tempSurface :: Surface , widthHeight :: (Double,Double) , tempSelectInfo :: a } type TempSelection = TempSelectRender [RItem] data ItmsNImg = ItmsNImg { itmNimg_itms :: [RItem] , itmNimg_mbbx :: Maybe BBox , imageSurface :: Surface } -- | mkItmsNImg :: CanvasGeometry -> Page SelectMode -> IO ItmsNImg mkItmsNImg _geometry tpage = do let itms = getSelectedItms tpage drawselection = mapM_ renderRItem itms -- (renderItem.rItem2Item) itms Dim cw ch = view gdimension tpage mbbox = case getULBBoxFromSelected tpage of Middle bbox -> Just bbox _ -> Nothing sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch) renderWith sfc $ do setSourceRGBA 1 1 1 0 rectangle 0 0 cw ch fill setSourceRGBA 0 0 0 1 drawselection return $ ItmsNImg itms mbbox sfc -- | drawTempSelectImage :: CanvasGeometry -> TempSelectRender ItmsNImg -> Matrix -- ^ transformation matrix -> Render () drawTempSelectImage geometry tempselection xformmat = do let sfc = imageSurface (tempSelectInfo tempselection) CanvasDimension (Dim cw ch) = canvasDim geometry invxformmat = invert xformmat newvbbox = BBox (transformPoint invxformmat (0,0)) (transformPoint invxformmat (cw,ch)) mbbox = itmNimg_mbbx (tempSelectInfo tempselection) newmbbox = case unIntersect (Intersect (Middle newvbbox) `mappend` fromMaybe mbbox) of Middle bbox -> Just bbox _ -> Just newvbbox setMatrix xformmat clipBBox newmbbox setSourceSurface sfc 0 0 setOperator OperatorOver paint -- | tempSelected :: TempSelection -> [RItem] tempSelected = tempSelectInfo mkTempSelection :: Surface -> (Double,Double) -> [RItem] -> TempSelection mkTempSelection sfc (w,h) = TempSelectRender sfc (w,h) -- | update the content of temp selection. should not be often updated updateTempSelection :: TempSelectRender a -> Render () -> Bool -> IO () updateTempSelection tempselection renderfunc isFullErase = renderWith (tempSurface tempselection) $ do when isFullErase $ do let (cw,ch) = widthHeight tempselection setSourceRGBA 0.5 0.5 0.5 1 rectangle 0 0 cw ch fill renderfunc -- | getNewCoordTime :: ((Double,Double),UTCTime) -> (Double,Double) -> IO (Bool,((Double,Double),UTCTime)) getNewCoordTime (prev,otime) (x,y) = do ntime <- getCurrentTime let dtime = diffUTCTime ntime otime willUpdate = dtime > dtime_bound (nprev,nntime) = if dtime > dtime_bound then ((x,y),ntime) else (prev,otime) return (willUpdate,(nprev,nntime)) -- | adjustItemPosition4Paste :: CanvasGeometry -> PageNum -> [RItem] -> [RItem] adjustItemPosition4Paste geometry pgn itms = case bbox of Middle (BBox (xs0,ys0) _) -> fmap (changeItemBy (offsetFunc (x0-xs0,y0-ys0))) itms _ -> itms where bbox = bbox4All itms ViewPortBBox (BBox (xv0,yv0) _) = canvasViewPort geometry (x0,y0) = maybe (0,0) (\(pgn',norigin) -> if pgn == pgn' then unPageCoord norigin else (0,0)) $ desktop2Page geometry (DeskCoord (xv0,yv0))