hxournal-0.6.4: lib/Application/HXournal/Type/Canvas.hs
{-# LANGUAGE TemplateHaskell, TypeOperators, ExistentialQuantification,
Rank2Types, GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module : Application.HXournal.Type.Canvas
-- Copyright : (c) 2011, 2012 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Application.HXournal.Type.Canvas where
import Application.HXournal.Type.Enum
import Application.HXournal.Type.Alias
import Data.Sequence
import qualified Data.IntMap as M
import Control.Applicative ((<*>),(<$>))
import Control.Category
import Data.Label
import Prelude hiding ((.), id)
import Graphics.UI.Gtk hiding (get,set)
import Data.Xournal.Simple (Dimension(..))
import Data.Xournal.BBox
import Data.Xournal.Generic
import Data.Xournal.Predefined
import Application.HXournal.Type.PageArrangement
import Control.Monad.Identity (Identity(..))
type CanvasId = Int
data PenDraw = PenDraw { _points :: Seq (Double,Double) }
deriving (Show)
emptyPenDraw :: PenDraw
emptyPenDraw = PenDraw empty
data ViewInfo a = (ViewMode a) =>
ViewInfo { _zoomMode :: ZoomMode
, _pageArrangement :: PageArrangement a }
defaultViewInfoSinglePage :: ViewInfo SinglePage
defaultViewInfoSinglePage =
ViewInfo { _zoomMode = Original
, _pageArrangement =
SingleArrangement (CanvasDimension (Dim 100 100))
(PageDimension (Dim 100 100))
(ViewPortBBox (BBox (0,0) (100,100))) }
zoomMode :: ViewInfo a :-> ZoomMode
zoomMode = lens _zoomMode (\a f -> f { _zoomMode = a } )
pageArrangement :: ViewInfo a :-> PageArrangement a
pageArrangement = lens _pageArrangement (\a f -> f { _pageArrangement = a })
data CanvasInfo a =
(ViewMode a) => CanvasInfo { _canvasId :: CanvasId
, _drawArea :: DrawingArea
, _scrolledWindow :: ScrolledWindow
, _viewInfo :: ViewInfo a
, _currentPageNum :: Int
, _currentPage :: Either (Page EditMode) (Page SelectMode)
, _horizAdjustment :: Adjustment
, _vertAdjustment :: Adjustment
, _horizAdjConnId :: Maybe (ConnectId Adjustment)
, _vertAdjConnId :: Maybe (ConnectId Adjustment)
}
defaultCvsInfoSinglePage :: CanvasInfo SinglePage
defaultCvsInfoSinglePage =
CanvasInfo { _canvasId = error "cvsid"
, _drawArea = error "DrawingArea"
, _scrolledWindow = error "ScrolledWindow"
, _viewInfo = defaultViewInfoSinglePage
, _currentPageNum = 0
, _currentPage = error "currentPage"
, _horizAdjustment = error "adjustment"
, _vertAdjustment = error "vadjust"
, _horizAdjConnId = Nothing
, _vertAdjConnId = Nothing
}
canvasId :: CanvasInfo a :-> CanvasId
canvasId = lens _canvasId (\a f -> f { _canvasId = a })
drawArea :: CanvasInfo a :-> DrawingArea
drawArea = lens _drawArea (\a f -> f { _drawArea = a })
scrolledWindow :: CanvasInfo a :-> ScrolledWindow
scrolledWindow = lens _scrolledWindow (\a f -> f { _scrolledWindow = a })
viewInfo :: CanvasInfo a :-> ViewInfo a
viewInfo = lens _viewInfo (\a f -> f { _viewInfo = a })
currentPageNum :: CanvasInfo a :-> Int
currentPageNum = lens _currentPageNum (\a f -> f { _currentPageNum = a })
currentPage :: CanvasInfo a :-> Either (Page EditMode) (Page SelectMode)
currentPage = lens _currentPage (\a f -> f { _currentPage = a })
horizAdjustment :: CanvasInfo a :-> Adjustment
horizAdjustment = lens _horizAdjustment (\a f -> f { _horizAdjustment = a })
vertAdjustment :: CanvasInfo a :-> Adjustment
vertAdjustment = lens _vertAdjustment (\a f -> f { _vertAdjustment = a })
horizAdjConnId :: CanvasInfo a :-> Maybe (ConnectId Adjustment )
horizAdjConnId = lens _horizAdjConnId (\a f -> f { _horizAdjConnId = a })
vertAdjConnId :: CanvasInfo a :-> Maybe (ConnectId Adjustment)
vertAdjConnId = lens _vertAdjConnId (\a f -> f { _vertAdjConnId = a })
-- |
adjustments :: CanvasInfo a :-> (Adjustment,Adjustment)
adjustments = Lens $ (,) <$> (fst `for` horizAdjustment)
<*> (snd `for` vertAdjustment)
data CanvasInfoBox = forall a. (ViewMode a) => CanvasInfoBox (CanvasInfo a)
getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea
getDrawAreaFromBox = unboxGet drawArea -- (CanvasInfoBox x) = get drawArea x
unboxGet :: (forall a. (ViewMode a) => CanvasInfo a :-> b) -> CanvasInfoBox -> b
unboxGet f (CanvasInfoBox x) = get f x
fmapBox :: (forall a. (ViewMode a) => CanvasInfo a -> CanvasInfo a)
-> CanvasInfoBox -> CanvasInfoBox
fmapBox f (CanvasInfoBox cinfo) = CanvasInfoBox (f cinfo)
boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b)
-> CanvasInfoBox -> m b
boxAction f (CanvasInfoBox cinfo) = f cinfo
selectBoxAction :: (Monad m) =>
(CanvasInfo SinglePage -> m a)
-> (CanvasInfo ContinuousSinglePage -> m a) -> CanvasInfoBox -> m a
selectBoxAction fsingle fcont (CanvasInfoBox cinfo) =
case get (pageArrangement.viewInfo) cinfo of
SingleArrangement _ _ _ -> fsingle cinfo
ContinuousSingleArrangement _ _ _ _ -> fcont cinfo
selectBox :: (CanvasInfo SinglePage -> CanvasInfo SinglePage)
-> (CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage)
-> CanvasInfoBox -> CanvasInfoBox
selectBox fsingle fcont =
let idaction :: CanvasInfoBox -> Identity CanvasInfoBox
idaction = selectBoxAction (return . CanvasInfoBox . fsingle) (return . CanvasInfoBox . fcont)
in runIdentity . idaction
pageArrEitherFromCanvasInfoBox :: CanvasInfoBox
-> Either (PageArrangement SinglePage) (PageArrangement ContinuousSinglePage)
pageArrEitherFromCanvasInfoBox (CanvasInfoBox cinfo) =
pageArrEither . get (pageArrangement.viewInfo) $ cinfo
viewModeBranch :: (CanvasInfo SinglePage -> CanvasInfo SinglePage)
-> (CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage)
-> CanvasInfo v -> CanvasInfo v
viewModeBranch fsingle fcont cinfo =
case get (pageArrangement.viewInfo) cinfo of
SingleArrangement _ _ _ -> fsingle cinfo
ContinuousSingleArrangement _ _ _ _ -> fcont cinfo
type CanvasInfoMap = M.IntMap CanvasInfoBox
data PenType = PenWork
| HighlighterWork
| EraserWork
| TextWork
deriving (Show,Eq)
data WidthColorStyle = WidthColorStyle { _penWidth :: Double
, _penColor :: PenColor }
deriving (Show)
data PenHighlighterEraserSet = PenHighlighterEraserSet
{ _currPen :: WidthColorStyle
, _currHighlighter :: WidthColorStyle
, _currEraser :: WidthColorStyle
, _currText :: WidthColorStyle}
deriving (Show)
data PenInfo = PenInfo { _penType :: PenType
, _penSet :: PenHighlighterEraserSet }
deriving (Show)
currentTool :: PenInfo :-> WidthColorStyle
currentTool = lens chooser setter
where chooser pinfo = case _penType pinfo of
PenWork -> _currPen . _penSet $ pinfo
HighlighterWork -> _currHighlighter . _penSet $ pinfo
EraserWork -> _currEraser . _penSet $ pinfo
TextWork -> _currText . _penSet $ pinfo
setter wcs pinfo =
let pset = _penSet pinfo
psetnew = case _penType pinfo of
PenWork -> pset { _currPen = wcs }
HighlighterWork -> pset { _currHighlighter = wcs }
EraserWork -> pset { _currEraser = wcs }
TextWork -> pset { _currText = wcs }
in pinfo { _penSet = psetnew }
defaultPenWCS :: WidthColorStyle
defaultPenWCS = WidthColorStyle predefined_medium ColorBlack
defaultEraserWCS :: WidthColorStyle
defaultEraserWCS = WidthColorStyle predefined_eraser_medium ColorWhite
defaultTextWCS :: WidthColorStyle
defaultTextWCS = defaultPenWCS
defaultHighligherWCS :: WidthColorStyle
defaultHighligherWCS = WidthColorStyle predefined_highlighter_medium ColorYellow
defaultPenInfo :: PenInfo
defaultPenInfo =
PenInfo { _penType = PenWork
, _penSet = PenHighlighterEraserSet { _currPen = defaultPenWCS
, _currHighlighter = defaultHighligherWCS
, _currEraser = defaultEraserWCS
, _currText = defaultTextWCS }
}
$(mkLabels [''PenDraw, ''ViewInfo, ''PenInfo, ''PenHighlighterEraserSet, ''WidthColorStyle ])
-- |
getPage :: (ViewMode a) => CanvasInfo a -> (Page EditMode)
getPage = either id (gcast :: Page SelectMode -> Page EditMode) . get currentPage
-- |
updateCanvasDimForSingle :: CanvasDimension
-> CanvasInfo SinglePage
-> CanvasInfo SinglePage
updateCanvasDimForSingle cdim@(CanvasDimension (Dim w' h')) cinfo =
let zmode = get (zoomMode.viewInfo) cinfo
arr@(SingleArrangement _ pdim vbbox@(ViewPortBBox bbox))
= get (pageArrangement.viewInfo) cinfo
(x,y) = bbox_upperleft bbox
(sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim
nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy)
arr' = SingleArrangement cdim pdim (ViewPortBBox nbbox)
in set (pageArrangement.viewInfo) arr' cinfo
-- |
updateCanvasDimForContSingle :: CanvasDimension
-> CanvasInfo ContinuousSinglePage
-> CanvasInfo ContinuousSinglePage
updateCanvasDimForContSingle cdim@(CanvasDimension (Dim w' h')) cinfo =
let zmode = get (zoomMode.viewInfo) cinfo
arr@(ContinuousSingleArrangement _ ddim func vbbox@(ViewPortBBox bbox))
= get (pageArrangement.viewInfo) cinfo
(x,y) = bbox_upperleft bbox
dim = get g_dimension . getPage $ cinfo
(sinvx,sinvy) = getRatioPageCanvas zmode (PageDimension dim) cdim
nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy)
arr' = ContinuousSingleArrangement cdim ddim func (ViewPortBBox nbbox)
in set (pageArrangement.viewInfo) arr' cinfo