content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# OPTIONS_GHC -fno-warn-incomplete-record-updates #-}
  
  module Hoodle.Type.Canvas
    ( -- * data types
      CanvasId,
      PenDraw (..),
      emptyPenDraw,
      ViewInfo (..),
      CanvasInfo (..),
      CanvasInfoBox (..),
      CanvasInfoMap,
      MyScrollWindow (..),
      PenHighlighterEraserSet,
      PenInfo,
      WidthColorStyle,
  
      -- * default constructor
      defaultViewInfoSinglePage,
      defaultCvsInfoSinglePage,
      defaultCanvasWidgets,
      defaultPenWCS,
      defaultEraserWCS,
      defaultTextWCS,
      defaultHighligherWCS,
      defaultPenInfo,
  
      -- * lenses
      points,
      zoomMode,
      pageArrangement,
      canvasId,
      drawArea,
      mDrawSurface,
      scrolledWindow,
      viewInfo,
      currentPageNum,
      -- , currentPage
      horizAdjustment,
      vertAdjustment,
      horizAdjConnId,
      vertAdjConnId,
      adjustments,
      canvasWidgets,
      notifiedItem,
      -- , panZoomWidgetPosition
      currentTool,
      penWidth,
      penColor,
      currPen,
      currHighlighter,
      currEraser,
      currText,
      currVerticalSpace,
      penType,
      penSet,
      variableWidthPen,
  
      -- * for box
      xfrmCvsInfo,
      xfrmViewInfo,
      getDrawAreaFromBox,
      unboxLens,
      unboxBiAct,
      unboxBiXform,
      forBoth,
      forBoth',
  
      -- * others
      updateCanvasDimForSingle,
      updateCanvasDimForContSingle,
    )
  where
  
  import Control.Lens (Lens', lens, set, view)
  import Data.Hoodle.BBox (BBox (..))
  import Data.Hoodle.Predefined
    ( predefinedEraserMedium,
      predefinedHighlighterMedium,
      predefinedMedium,
    )
  import Data.Hoodle.Simple (Dimension (..))
  import qualified Data.IntMap as M
  import Data.Sequence (Seq, empty)
  import Graphics.Hoodle.Render.Type.Item (RItem)
  import Graphics.Hoodle.Render.Type.Renderer (CanvasId)
  import qualified Graphics.Rendering.Cairo as Cairo
  import qualified Graphics.UI.Gtk as Gtk
  import Hoodle.Type.Enum
    ( PenColor (..),
      PenType (..),
    )
  import Hoodle.Type.PageArrangement
    ( CanvasDimension (..),
      PageArrangement (..),
      PageDimension (..),
      PageNum (..),
      ViewMode (..),
      ViewPortBBox (..),
      ZoomMode (..),
      getRatioPageCanvas,
    )
  import Hoodle.Type.Widget
    ( CanvasWidgets,
      defaultCanvasWidgets,
    )
  
  -- |
  newtype PenDraw = PenDraw {_points :: Seq (Double, Double)}
    deriving (Show)
  
  -- | lens for zoomMode
  points :: Lens' PenDraw (Seq (Double, Double))
  points = lens _points (\f a -> f {_points = a})
  
  -- |
  data ViewInfo (a :: ViewMode) = ViewInfo
    { _zoomMode :: ZoomMode,
      _pageArrangement :: PageArrangement a
    }
  
  xfrmViewInfo ::
    (PageArrangement a -> PageArrangement b) ->
    ViewInfo a ->
    ViewInfo b
  xfrmViewInfo f ViewInfo {..} =
    ViewInfo
      { _zoomMode = _zoomMode,
        _pageArrangement = f _pageArrangement
      }
  
  -- |
  emptyPenDraw :: PenDraw
  emptyPenDraw = PenDraw empty
  
  -- | default view info with single page mode
  defaultViewInfoSinglePage :: ViewInfo 'SinglePage
  defaultViewInfoSinglePage =
    ViewInfo
      { _zoomMode = Original,
        _pageArrangement =
          SingleArrangement
            (CanvasDimension (Dim 100 100))
            (PageDimension (Dim 100 100))
            (ViewPortBBox (BBox (0, 0) (100, 100)))
      }
  
  -- | lens for zoomMode
  zoomMode :: Lens' (ViewInfo a) ZoomMode
  zoomMode = lens _zoomMode (\f a -> f {_zoomMode = a})
  
  -- |
  pageArrangement :: Lens' (ViewInfo a) (PageArrangement a)
  pageArrangement = lens _pageArrangement (\f a -> f {_pageArrangement = a})
  
  data MyScrollWindow = MyScrollWindow
    { _scrollCanvas :: Gtk.VBox,
      _scrollHScrollbar :: Gtk.HScrollbar,
      _scrollVScrollbar :: Gtk.VScrollbar
    }
  
  -- |
  data CanvasInfo (a :: ViewMode) = CanvasInfo
    { _canvasId :: CanvasId,
      _drawArea :: Gtk.DrawingArea,
      _mDrawSurface :: Maybe Cairo.Surface,
      _scrolledWindow :: MyScrollWindow, -- Gtk.ScrolledWindow
      _viewInfo :: ViewInfo a,
      _currentPageNum :: Int,
      _horizAdjustment :: Gtk.Adjustment,
      _vertAdjustment :: Gtk.Adjustment,
      _horizAdjConnId :: Maybe (Gtk.ConnectId Gtk.Adjustment),
      _vertAdjConnId :: Maybe (Gtk.ConnectId Gtk.Adjustment),
      _canvasWidgets :: CanvasWidgets,
      _notifiedItem :: Maybe (PageNum, BBox, RItem)
    }
  
  -- |
  xfrmCvsInfo ::
    (ViewInfo a -> ViewInfo b) ->
    CanvasInfo a ->
    CanvasInfo b
  xfrmCvsInfo f CanvasInfo {..} =
    CanvasInfo
      { _canvasId = _canvasId,
        _drawArea = _drawArea,
        _mDrawSurface = _mDrawSurface,
        _scrolledWindow = _scrolledWindow,
        _viewInfo = f _viewInfo,
        _currentPageNum = _currentPageNum,
        _horizAdjustment = _horizAdjustment,
        _vertAdjustment = _vertAdjustment,
        _horizAdjConnId = _horizAdjConnId,
        _vertAdjConnId = _vertAdjConnId,
        _canvasWidgets = _canvasWidgets,
        _notifiedItem = _notifiedItem
      }
  
  -- |
  defaultCvsInfoSinglePage :: CanvasInfo 'SinglePage
  defaultCvsInfoSinglePage =
    CanvasInfo
      { _canvasId = error "defaultCvsInfoSinglePage cvsid",
        _drawArea = error "defaultCvsInfoSinglePage DrawingArea",
        _mDrawSurface = Nothing,
        _scrolledWindow = error "ScrolledWindow",
        _viewInfo = defaultViewInfoSinglePage,
        _currentPageNum = 0,
        _horizAdjustment = error "adjustment",
        _vertAdjustment = error "vadjust",
        _horizAdjConnId = Nothing,
        _vertAdjConnId = Nothing,
        _canvasWidgets = defaultCanvasWidgets,
        _notifiedItem = Nothing
      }
  
  -- |
  canvasId :: Lens' (CanvasInfo a) CanvasId
  canvasId = lens _canvasId (\f a -> f {_canvasId = a})
  
  -- |
  drawArea :: Lens' (CanvasInfo a) Gtk.DrawingArea
  drawArea = lens _drawArea (\f a -> f {_drawArea = a})
  
  -- |
  mDrawSurface :: Lens' (CanvasInfo a) (Maybe Cairo.Surface)
  mDrawSurface = lens _mDrawSurface (\f a -> f {_mDrawSurface = a})
  
  -- |
  scrolledWindow :: Lens' (CanvasInfo a) MyScrollWindow
  scrolledWindow = lens _scrolledWindow (\f a -> f {_scrolledWindow = a})
  
  -- |
  viewInfo :: Lens' (CanvasInfo a) (ViewInfo a)
  viewInfo = lens _viewInfo (\f a -> f {_viewInfo = a})
  
  -- |
  currentPageNum :: Lens' (CanvasInfo a) Int
  currentPageNum = lens _currentPageNum (\f a -> f {_currentPageNum = a})
  
  -- |
  horizAdjustment :: Lens' (CanvasInfo a) Gtk.Adjustment
  horizAdjustment = lens _horizAdjustment (\f a -> f {_horizAdjustment = a})
  
  -- |
  vertAdjustment :: Lens' (CanvasInfo a) Gtk.Adjustment
  vertAdjustment = lens _vertAdjustment (\f a -> f {_vertAdjustment = a})
  
  -- | ConnectId for horizontal scrollbar value change event
  horizAdjConnId :: Lens' (CanvasInfo a) (Maybe (Gtk.ConnectId Gtk.Adjustment))
  horizAdjConnId = lens _horizAdjConnId (\f a -> f {_horizAdjConnId = a})
  
  -- | ConnectId for vertical scrollbar value change event
  vertAdjConnId :: Lens' (CanvasInfo a) (Maybe (Gtk.ConnectId Gtk.Adjustment))
  vertAdjConnId = lens _vertAdjConnId (\f a -> f {_vertAdjConnId = a})
  
  -- | composition lens
  adjustments :: Lens' (CanvasInfo a) (Gtk.Adjustment, Gtk.Adjustment)
  adjustments = lens getter setter
    where
      getter = (,) <$> view horizAdjustment <*> view vertAdjustment
      setter f (h, v) = set horizAdjustment h . set vertAdjustment v $ f
  
  -- | lens for canavs widgets
  canvasWidgets :: Lens' (CanvasInfo a) CanvasWidgets
  canvasWidgets = lens _canvasWidgets (\f a -> f {_canvasWidgets = a})
  
  -- | lens for notified item
  notifiedItem :: Lens' (CanvasInfo a) (Maybe (PageNum, BBox, RItem))
  notifiedItem = lens _notifiedItem (\f a -> f {_notifiedItem = a})
  
  -- |
  data CanvasInfoBox where
    CanvasSinglePage :: CanvasInfo 'SinglePage -> CanvasInfoBox
    CanvasContPage :: CanvasInfo 'ContinuousPage -> CanvasInfoBox
  
  forBoth ::
    ( (CanvasInfo 'SinglePage -> f (CanvasInfo 'SinglePage)) ->
      (CanvasInfo 'ContinuousPage -> f (CanvasInfo 'ContinuousPage)) ->
      (CanvasInfoBox -> f CanvasInfoBox)
    ) ->
    (forall a. CanvasInfo a -> f (CanvasInfo a)) ->
    CanvasInfoBox ->
    f CanvasInfoBox
  forBoth m f = m f f
  
  forBoth' ::
    ( (CanvasInfo 'SinglePage -> r) ->
      (CanvasInfo 'ContinuousPage -> r) ->
      (CanvasInfoBox -> r)
    ) ->
    (forall a. CanvasInfo a -> r) ->
    CanvasInfoBox ->
    r
  forBoth' m f = m f f
  
  -- | single page action and continuous page act
  unboxBiXform ::
    (Functor f) =>
    (CanvasInfo 'SinglePage -> f (CanvasInfo 'SinglePage)) ->
    (CanvasInfo 'ContinuousPage -> f (CanvasInfo 'ContinuousPage)) ->
    CanvasInfoBox ->
    f CanvasInfoBox
  unboxBiXform fsingle _fcont (CanvasSinglePage cinfo) = fmap CanvasSinglePage (fsingle cinfo)
  unboxBiXform _fsingle fcont (CanvasContPage cinfo) = fmap CanvasContPage (fcont cinfo)
  
  -- | single page action and continuous page act
  unboxBiAct ::
    (CanvasInfo 'SinglePage -> r) ->
    (CanvasInfo 'ContinuousPage -> r) ->
    CanvasInfoBox ->
    r
  unboxBiAct fsingle _fcont (CanvasSinglePage cinfo) = fsingle cinfo
  unboxBiAct _fsingle fcont (CanvasContPage cinfo) = fcont cinfo
  
  -- |
  unboxGet :: (forall a. Lens' (CanvasInfo a) b) -> CanvasInfoBox -> b
  unboxGet f = forBoth' unboxBiAct (view f)
  
  -- |
  unboxSet :: (forall a. Lens' (CanvasInfo a) b) -> b -> CanvasInfoBox -> CanvasInfoBox
  unboxSet l b (CanvasSinglePage a) = CanvasSinglePage (set l b a)
  unboxSet l b (CanvasContPage a) = CanvasContPage (set l b a)
  
  unboxLens :: (forall a. Lens' (CanvasInfo a) b) -> Lens' CanvasInfoBox b
  unboxLens l = lens (unboxGet l) (flip (unboxSet l))
  
  -- |
  getDrawAreaFromBox :: CanvasInfoBox -> Gtk.DrawingArea
  getDrawAreaFromBox = view (unboxLens drawArea)
  
  -- |
  type CanvasInfoMap = M.IntMap CanvasInfoBox
  
  -- |
  data WidthColorStyle
    = WidthColorStyle
        { _penWidth :: Double,
          _penColor :: PenColor
        }
    | NoWidthColorStyle
    deriving (Show)
  
  -- | lens for penWidth
  penWidth :: Lens' WidthColorStyle Double
  penWidth = lens _penWidth (\f a -> f {_penWidth = a})
  
  -- | lens for penColor
  penColor :: Lens' WidthColorStyle PenColor
  penColor = lens _penColor (\f a -> f {_penColor = a})
  
  -- |
  data PenHighlighterEraserSet = PenHighlighterEraserSet
    { _currPen :: WidthColorStyle,
      _currHighlighter :: WidthColorStyle,
      _currEraser :: WidthColorStyle,
      _currText :: WidthColorStyle,
      _currVerticalSpace :: WidthColorStyle
    }
    deriving (Show)
  
  -- | lens for currPen
  currPen :: Lens' PenHighlighterEraserSet WidthColorStyle
  currPen = lens _currPen (\f a -> f {_currPen = a})
  
  -- | lens for currHighlighter
  currHighlighter :: Lens' PenHighlighterEraserSet WidthColorStyle
  currHighlighter = lens _currHighlighter (\f a -> f {_currHighlighter = a})
  
  -- | lens for currEraser
  currEraser :: Lens' PenHighlighterEraserSet WidthColorStyle
  currEraser = lens _currEraser (\f a -> f {_currEraser = a})
  
  -- | lens for currText
  currText :: Lens' PenHighlighterEraserSet WidthColorStyle
  currText = lens _currText (\f a -> f {_currText = a})
  
  -- | lens for currText
  currVerticalSpace :: Lens' PenHighlighterEraserSet WidthColorStyle
  currVerticalSpace =
    lens
      _currVerticalSpace
      (\f a -> f {_currVerticalSpace = a})
  
  -- |
  data PenInfo = PenInfo
    { _penType :: PenType,
      _penSet :: PenHighlighterEraserSet,
      _variableWidthPen :: Bool
    }
    deriving (Show)
  
  -- | lens for penType
  penType :: Lens' PenInfo PenType
  penType = lens _penType (\f a -> f {_penType = a})
  
  -- | lens for penSet
  penSet :: Lens' PenInfo PenHighlighterEraserSet
  penSet = lens _penSet (\f a -> f {_penSet = a})
  
  -- | lens for variableWidthPen
  variableWidthPen :: Lens' PenInfo Bool
  variableWidthPen = lens _variableWidthPen (\f a -> f {_variableWidthPen = a})
  
  -- |
  currentTool :: Lens' 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
        VerticalSpaceWork -> NoWidthColorStyle
      setter pinfo wcs =
        let pset = _penSet pinfo
            psetnew = case _penType pinfo of
              PenWork -> pset {_currPen = wcs}
              HighlighterWork -> pset {_currHighlighter = wcs}
              EraserWork -> pset {_currEraser = wcs}
              VerticalSpaceWork -> pset
         in pinfo {_penSet = psetnew}
  
  -- |
  defaultPenWCS :: WidthColorStyle
  defaultPenWCS = WidthColorStyle predefinedMedium ColorBlack
  
  -- |
  defaultEraserWCS :: WidthColorStyle
  defaultEraserWCS = WidthColorStyle predefinedEraserMedium ColorWhite
  
  -- |
  defaultTextWCS :: WidthColorStyle
  defaultTextWCS = defaultPenWCS
  
  -- |
  defaultHighligherWCS :: WidthColorStyle
  defaultHighligherWCS = WidthColorStyle predefinedHighlighterMedium ColorYellow
  
  -- |
  defaultPenInfo :: PenInfo
  defaultPenInfo =
    PenInfo
      { _penType = PenWork,
        _penSet =
          PenHighlighterEraserSet
            { _currPen = defaultPenWCS,
              _currHighlighter = defaultHighligherWCS,
              _currEraser = defaultEraserWCS,
              _currText = defaultTextWCS,
              _currVerticalSpace = NoWidthColorStyle
            },
        _variableWidthPen = False
      }
  
  -- |
  updateCanvasDimForSingle ::
    CanvasDimension ->
    CanvasInfo 'SinglePage ->
    IO (CanvasInfo 'SinglePage)
  updateCanvasDimForSingle cdim@(CanvasDimension (Dim w' h')) cinfo = do
    let zmode = view (viewInfo . zoomMode) cinfo
        SingleArrangement _ pdim (ViewPortBBox bbox) =
          view (viewInfo . pageArrangement) 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)
    maybe (return ()) Cairo.surfaceFinish $ view mDrawSurface cinfo
    msfc <- fmap Just $ do
      sfc <-
        Cairo.createImageSurface
          Cairo.FormatARGB32
          (floor w')
          (floor h')
      Cairo.renderWith sfc $ do
        Cairo.setSourceRGBA 0.5 0.5 0.5 1
        Cairo.rectangle 0 0 w' h'
        Cairo.fill
      return sfc
    return $ (set (viewInfo . pageArrangement) arr' . set mDrawSurface msfc) cinfo
  
  -- |
  updateCanvasDimForContSingle ::
    PageDimension ->
    CanvasDimension ->
    CanvasInfo 'ContinuousPage ->
    IO (CanvasInfo 'ContinuousPage)
  updateCanvasDimForContSingle pdim cdim@(CanvasDimension (Dim w' h')) cinfo = do
    let zmode = view (viewInfo . zoomMode) cinfo
        ContinuousArrangement _ ddim func (ViewPortBBox bbox) =
          view (viewInfo . pageArrangement) cinfo
        (x, y) = bbox_upperleft bbox
        (sinvx, sinvy) = getRatioPageCanvas zmode pdim cdim
        nbbox = BBox (x, y) (x + w' / sinvx, y + h' / sinvy)
        arr' = ContinuousArrangement cdim ddim func (ViewPortBBox nbbox)
    maybe (return ()) Cairo.surfaceFinish $ view mDrawSurface cinfo
    msfc <- fmap Just $ do
      sfc <-
        Cairo.createImageSurface
          Cairo.FormatARGB32
          (floor w')
          (floor h')
      Cairo.renderWith sfc $ do
        Cairo.setSourceRGBA 0.5 0.5 0.5 1
        Cairo.rectangle 0 0 w' h'
        Cairo.fill
      return sfc
    return $ (set (viewInfo . pageArrangement) arr' . set mDrawSurface msfc) cinfo
  