{-# LANGUAGE GADTs #-}

-----------------------------------------------------------------------------
-- |
-- Module      : Hoodle.Coroutine.Page 
-- Copyright   : (c) 2011-2013 Ian-Woo Kim
--
-- License     : BSD3
-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------

module Hoodle.Coroutine.Page where

import           Control.Lens (view,set,over)
import           Control.Monad
import           Control.Monad.State
import qualified Data.IntMap as M
-- from hoodle-platform
import           Data.Hoodle.Generic
import           Data.Hoodle.Select
import           Graphics.Hoodle.Render.Type.Background
-- from this package
import           Hoodle.Accessor
import           Hoodle.Coroutine.Draw
import           Hoodle.Coroutine.Commit
import           Hoodle.Coroutine.Scroll
import           Hoodle.ModelAction.Page
import           Hoodle.Type.Alias
import           Hoodle.Type.Coroutine
import           Hoodle.Type.Canvas
import           Hoodle.Type.PageArrangement
import           Hoodle.Type.HoodleState
import           Hoodle.Type.Enum
import           Hoodle.Util
import           Hoodle.View.Coordinate
-- 

-- | change page of current canvas using a modify function
changePage :: (Int -> Int) -> MainCoroutine () 
changePage modifyfn = updateXState changePageAction 
                      >> adjustScrollbarWithGeometryCurrent
                      >> invalidateAllInBBox Nothing Efficient  
  where changePageAction xst = unboxBiAct (fsingle xst) (fcont xst) 
                               . view currentCanvasInfo $ xst
        fsingle xstate cvsInfo = do 
          let xojst = view hoodleModeState $ xstate  
              npgnum = modifyfn (view currentPageNum cvsInfo)
              cid = view canvasId cvsInfo
              bsty = view backgroundStyle xstate 
              (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst
          xstate' <- liftIO $ updatePageAll xojst' xstate 
          ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid
          xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'
          when b (commit xstatefinal)
          return xstatefinal 
        
        fcont xstate cvsInfo = do 
          let xojst = view hoodleModeState xstate  
              npgnum = modifyfn (view currentPageNum cvsInfo)
              cid = view canvasId cvsInfo
              bsty = view backgroundStyle xstate 
              (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst
          xstate' <- liftIO $ updatePageAll xojst' xstate 
          ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid
          xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'
          when b (commit xstatefinal)
          return xstatefinal 


-- | 
changePageInHoodleModeState :: BackgroundStyle 
                            -> Int  -- ^ new page number 
                            -> HoodleModeState 
                            -> (Bool,Int,Page EditMode,HoodleModeState)
changePageInHoodleModeState bsty npgnum hdlmodst =
    let ehdl = hoodleModeStateEither hdlmodst 
        pgs = either (view gpages) (view gselAll) ehdl
        totnumpages = M.size pgs
        lpage = maybeError' "changePage" (M.lookup (totnumpages-1) pgs)
        (isChanged,npgnum',npage',ehdl') 
          | npgnum >= totnumpages = 
            let cbkg = view gbackground lpage
                nbkg 
                  | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } 
                  | otherwise = cbkg 
                npage = set gbackground nbkg 
                        . newSinglePageFromOld $ lpage
                npages = M.insert totnumpages npage pgs 
            in (True,totnumpages,npage,
                 either (Left . set gpages npages) (Right. set gselAll npages) ehdl )
          | otherwise = let npg = if npgnum < 0 then 0 else npgnum
                            pg = maybeError' "changePage" (M.lookup npg pgs)
                        in (False,npg,pg,ehdl) 
    in (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl')


-- | 
canvasZoomUpdateGenRenderCvsId :: MainCoroutine () 
                                  -> CanvasId 
                                  -> Maybe ZoomMode 
                                  -> Maybe (PageNum,PageCoordinate) 
                                  -> MainCoroutine ()
canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord 
  = updateXState zoomUpdateAction 
    >> adjustScrollbarWithGeometryCvsId cid
    >> renderfunc
  where zoomUpdateAction xst =  
          unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst 
        fsingle xstate cinfo = do   
          geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo 
          page <- getCurrentPageCvsId cid
          let zmode = maybe (view (viewInfo.zoomMode) cinfo) id mzmode  
              pdim = PageDimension $ view gdimension page
              xy = either (const (0,0)) (unPageCoord.snd) 
                     (getCvsOriginInPage geometry)
              cdim = canvasDim geometry 
              narr = makeSingleArrangement zmode pdim cdim xy  
              ncinfobox = CanvasSinglePage
                          . set (viewInfo.pageArrangement) narr
                          . set (viewInfo.zoomMode) zmode $ cinfo
          return . modifyCanvasInfo cid (const ncinfobox) $ xstate
        fcont xstate cinfo = do   
          geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo 
          let zmode = maybe (view (viewInfo.zoomMode) cinfo) id mzmode 
              cpn = PageNum $ view currentPageNum cinfo 
              cdim = canvasDim geometry 
              hdl = getHoodle xstate 
              origcoord = case mcoord of
                            Just coord -> coord 
                            Nothing -> either (const (cpn,PageCoord (0,0))) id 
                                         (getCvsOriginInPage geometry)
              narr = makeContinuousArrangement zmode cdim hdl origcoord
              ncinfobox = CanvasContPage
                          . set (viewInfo.pageArrangement) narr
                          . set (viewInfo.zoomMode) zmode $ cinfo
          return . modifyCanvasInfo cid (const ncinfobox) $ xstate

-- | 
canvasZoomUpdateCvsId :: CanvasId 
                         -> Maybe ZoomMode 
                         -> MainCoroutine ()
canvasZoomUpdateCvsId cid mzmode = 
  canvasZoomUpdateGenRenderCvsId invalidateAll cid mzmode Nothing
  
-- | 
canvasZoomUpdateBufAll :: MainCoroutine () 
canvasZoomUpdateBufAll = do 
    klst <- liftM (M.keys . getCanvasInfoMap) get
    mapM_ updatefunc klst 
  where 
    updatefunc cid 
      = canvasZoomUpdateGenRenderCvsId  (invalidateInBBox Nothing Efficient cid) cid Nothing Nothing 


-- |
canvasZoomUpdateAll :: MainCoroutine () 
canvasZoomUpdateAll = do 
  klst <- liftM (M.keys . getCanvasInfoMap) get
  mapM_ (flip canvasZoomUpdateCvsId Nothing) klst 


-- | 
canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine () 
canvasZoomUpdate mzmode = do  
  cid <- (liftM (getCurrentCanvasId) get)
  canvasZoomUpdateCvsId cid mzmode

-- |
pageZoomChange :: ZoomMode -> MainCoroutine () 
pageZoomChange = canvasZoomUpdate . Just 

-- | 
pageZoomChangeRel :: ZoomModeRel -> MainCoroutine () 
pageZoomChangeRel rzmode = do 
    forBoth' unboxBiAct fsingle . view currentCanvasInfo =<< get 
  where 
    fsingle :: CanvasInfo a -> MainCoroutine ()
    fsingle cinfo = do 
      let cpn = PageNum (view currentPageNum cinfo)
          arr = view (viewInfo.pageArrangement) cinfo 
          canvas = view drawArea cinfo 
      geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
      let  nratio = relZoomRatio geometry rzmode
      pageZoomChange (Zoom nratio)

-- |
newPage :: AddDirection -> MainCoroutine () 
newPage dir = updateXState npgBfrAct 
              >> commit_ 
              >> canvasZoomUpdateAll 
              >> invalidateAll
  where 
    npgBfrAct xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst
    fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState
    fsimple xstate cinfo = do 
      case view hoodleModeState xstate of 
        ViewAppendState hdl -> do 
          let bsty = view backgroundStyle xstate 
              hdl' = addNewPageInHoodle bsty dir hdl (view currentPageNum cinfo)
          return =<< liftIO . updatePageAll (ViewAppendState hdl')
                     . set hoodleModeState  (ViewAppendState hdl') $ xstate 
        SelectState _ -> do 
          liftIO $ putStrLn " not implemented yet"
          return xstate
      
-- | delete current page of current canvas
deleteCurrentPage :: MainCoroutine ()           
deleteCurrentPage = do 
    updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll
  where 
    delpgact xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst
    fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState
    fsimple xstate cinfo = do 
      case view hoodleModeState xstate of 
        ViewAppendState hdl -> do 
          hdl' <- liftIO $ deletePageInHoodle hdl 
                             (PageNum (view currentPageNum cinfo))
          return =<< liftIO . updatePageAll (ViewAppendState hdl')
                     . set hoodleModeState  (ViewAppendState hdl') $ xstate 
        SelectState _ -> do 
          liftIO $ putStrLn " not implemented yet"
          return xstate
      
-- | delete designated page
deletePageInHoodle :: Hoodle EditMode -> PageNum -> IO (Hoodle EditMode)
deletePageInHoodle hdl (PageNum pgn) = do 
  let pagelst = M.elems . view gpages $ hdl 
      (pagesbefore,_cpage:pagesafter) = splitAt pgn pagelst
      npagelst = pagesbefore ++ pagesafter
      nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl
  return nhdl