hoodle-core-0.9: src/Hoodle/Coroutine/Default.hs
{-# LANGUAGE ScopedTypeVariables, GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Default
-- Copyright : (c) 2011, 2012 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.Default where
import Control.Applicative ((<$>))
import Control.Category
import Control.Concurrent
import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.IntMap as M
-- import Data.IntMap.Lens
import Data.Maybe
import Graphics.UI.Gtk hiding (get,set)
-- from hoodle-platform
-- import Control.Monad.Trans.Crtn
import Control.Monad.Trans.Crtn.Driver
-- import Control.Monad.Trans.Crtn.EventHandler
import Control.Monad.Trans.Crtn.Event
import Control.Monad.Trans.Crtn.Object
import Control.Monad.Trans.Crtn.Logger.Simple
import Control.Monad.Trans.Crtn.Queue
import Data.Hoodle.Select
import Data.Hoodle.Simple (Dimension(..), bkg_style)
import Data.Hoodle.Generic
import Graphics.Hoodle.Render.Type.Background
-- from this package
import Hoodle.Accessor
import Hoodle.Coroutine.Callback
import Hoodle.Coroutine.Commit
import Hoodle.Coroutine.ContextMenu
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.Eraser
import Hoodle.Coroutine.File
import Hoodle.Coroutine.Highlighter
import Hoodle.Coroutine.Layer
import Hoodle.Coroutine.Page
import Hoodle.Coroutine.Pen
import Hoodle.Coroutine.Scroll
import Hoodle.Coroutine.Select
import Hoodle.Coroutine.Select.Clipboard
import Hoodle.Coroutine.TextInput
import Hoodle.Coroutine.Mode
import Hoodle.Coroutine.Window
import Hoodle.Device
import Hoodle.GUI.Menu
import Hoodle.ModelAction.File
import Hoodle.ModelAction.Layer
import Hoodle.ModelAction.Page
import Hoodle.ModelAction.Window
import Hoodle.Script
import Hoodle.Script.Hook
import Hoodle.Type.Canvas
import Hoodle.Type.Clipboard
import Hoodle.Type.Coroutine
import Hoodle.Type.Enum
import Hoodle.Type.Event
import Hoodle.Type.PageArrangement
import Hoodle.Type.Undo
import Hoodle.Type.Window
import Hoodle.Type.HoodleState
--
import Prelude hiding ((.), id)
-- |
initCoroutine :: DeviceList
-> Window
-> Maybe FilePath
-> Maybe Hook
-> Int -- ^ maxundo
-> Bool -- ^ xinputbool
-> IO (EventVar,HoodleState,UIManager,VBox)
initCoroutine devlst window mfname mhook maxundo xinputbool = do
evar <- newEmptyMVar
putMVar evar Nothing
let st0new = set deviceList devlst
. set rootOfRootWindow window
. set callBack (eventHandler evar)
$ emptyHoodleState
ui <- getMenuUI evar
let st1 = set gtkUIManager ui st0new
initcvs = defaultCvsInfoSinglePage { _canvasId = 1 }
initcvsbox = CanvasSinglePage initcvs
st2 = set frameState (Node 1)
. updateFromCanvasInfoAsCurrentCanvas initcvsbox
$ st1 { _cvsInfoMap = M.empty }
(st3,cvs,_wconf) <- constructFrame st2 (view frameState st2)
(st4,wconf') <- eventConnect st3 (view frameState st3)
let st5 = set doesUseXInput xinputbool
. set hookSet mhook
. set undoTable (emptyUndo maxundo)
. set frameState wconf'
. set rootWindow cvs
$ st4
st6 <- getFileContent mfname st5
-- very dirty, need to be cleaned
let hdlst6 = view hoodleModeState st6
hdlst7 <- resetHoodleModeStateBuffers hdlst6
let st7 = set hoodleModeState hdlst7 st6
--
vbox <- vBoxNew False 0
--
let startingXstate = set rootContainer (castToBox vbox) st7
let startworld = world startingXstate . ReaderT $
(\(Arg DoEvent ev) -> guiProcess ev)
putMVar evar . Just $ (driver simplelogger startworld)
return (evar,startingXstate,ui,vbox)
-- |
initViewModeIOAction :: MainCoroutine HoodleState
initViewModeIOAction = do
oxstate <- get
let ui = view gtkUIManager oxstate
agr <- liftIO $ uiManagerGetActionGroups ui
Just ra <- liftIO $ actionGroupGetAction (head agr) "CONTA"
let wra = castToRadioAction ra
connid <- liftIO $ wra `on` radioActionChanged $ \x -> do
y <- viewModeToMyEvent x
view callBack oxstate y
return ()
let xstate = set pageModeSignal (Just connid) oxstate
put xstate
return xstate
-- | initialization according to the setting
initialize :: MyEvent -> MainCoroutine ()
initialize ev = do
liftIO $ putStrLn $ show ev
case ev of
Initialized -> do return ()
-- additional initialization goes here
viewModeChange ToContSinglePage
pageZoomChange (Zoom 0.3)
_ -> do ev' <- nextevent
initialize ev'
-- |
guiProcess :: MyEvent -> MainCoroutine ()
guiProcess ev = do
initialize ev
changePage (const 0)
xstate <- initViewModeIOAction
let cinfoMap = getCanvasInfoMap xstate
assocs = M.toList cinfoMap
f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox
(w',h') <- liftIO $ widgetGetSize canvas
defaultEventProcess (CanvasConfigure cid
(fromIntegral w')
(fromIntegral h'))
mapM_ f assocs
sequence_ (repeat dispatchMode)
-- |
dispatchMode :: MainCoroutine ()
dispatchMode = get >>= return . hoodleModeStateEither . view hoodleModeState
>>= either (const viewAppendMode) (const selectMode)
-- |
viewAppendMode :: MainCoroutine ()
viewAppendMode = do
r1 <- nextevent
case r1 of
PenDown cid pbtn pcoord -> do
ptype <- getPenType
case (ptype,pbtn) of
(PenWork,PenButton1) -> penStart cid pcoord
(PenWork,PenButton2) -> eraserStart cid pcoord
(PenWork,PenButton3) -> do
updateXState (return . set isOneTimeSelectMode YesBeforeSelect)
modeChange ToSelectMode
selectLassoStart cid pcoord
(PenWork,EraserButton) -> eraserStart cid pcoord
(EraserWork,_) -> eraserStart cid pcoord
(HighlighterWork,_) -> highlighterStart cid pcoord
-- _ -> return ()
_ -> defaultEventProcess r1
-- |
selectMode :: MainCoroutine ()
selectMode = do
r1 <- nextevent
case r1 of
PenDown cid _pbtn pcoord -> do
ptype <- liftM (view (selectInfo.selectType)) get
case ptype of
SelectRectangleWork -> selectRectStart cid pcoord
SelectRegionWork -> selectLassoStart cid pcoord
_ -> return ()
PenColorChanged c -> do modify (penInfo.currentTool.penColor .~ c)
selectPenColorChanged c
PenWidthChanged v -> do
w <- flip int2Point v . view (penInfo.penType) <$> get
modify (penInfo.currentTool.penWidth .~ w)
selectPenWidthChanged w
{- st <- get
let ptype = view (penInfo.penType) st
let w = int2Point ptype v
selectPenWidthChanged w
let stNew = set (penInfo.currentTool.penWidth) w st
put stNew -}
_ -> defaultEventProcess r1
-- |
defaultEventProcess :: MyEvent -> MainCoroutine ()
defaultEventProcess (UpdateCanvas cid) = invalidate cid
defaultEventProcess (Menu m) = menuEventProcess m
defaultEventProcess (HScrollBarMoved cid v) = hscrollBarMoved cid v
defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v
defaultEventProcess (VScrollBarStart cid v) = vscrollStart cid v
defaultEventProcess PaneMoveStart = paneMoveStart
defaultEventProcess (CanvasConfigure cid w' h') =
doCanvasConfigure cid (CanvasDimension (Dim w' h'))
defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode
defaultEventProcess ToSelectMode = modeChange ToSelectMode
defaultEventProcess ToSinglePage = viewModeChange ToSinglePage
defaultEventProcess ToContSinglePage = viewModeChange ToContSinglePage
defaultEventProcess (AssignPenMode t) =
case t of
Left pm -> do
-- xst <- get
-- let cvs = unboxGet drawArea . snd. view currentCanvas $ xst
-- win <- liftIO $ widgetGetDrawWindow cvs
-- cursor <- liftIO $ cursorNew BlankCursor
-- liftIO $ drawWindowSetCursor win (Just cursor)
modify (penInfo.penType .~ pm)
modeChange ToViewAppendMode
Right sm -> do
-- xst <- get
-- let cvs = unboxGet drawArea . snd. view currentCanvas $ xst
-- win <- liftIO $ widgetGetDrawWindow cvs
-- cursor <- cursorNew Dot
-- liftIO $ drawWindowSetCursor win Nothing
modify (selectInfo.selectType .~ sm)
modeChange ToSelectMode
defaultEventProcess (PenColorChanged c) =
modify (penInfo.currentTool.penColor .~ c)
defaultEventProcess (PenWidthChanged v) = do
st <- get
let ptype = view (penInfo.penType) st
let w = int2Point ptype v
let stNew = set (penInfo.currentTool.penWidth) w st
put stNew
defaultEventProcess (BackgroundStyleChanged bsty) = do
modify (backgroundStyle .~ bsty)
xstate <- get
let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate
hdl = getHoodle xstate
pgs = view gpages hdl
(_,cpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)
cbkg = view gbackground cpage
nbkg
| isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg
in bkg2RBkg bkg { bkg_style = convertBackgroundStyleToByteString bsty }
| otherwise = cbkg
npage = set gbackground nbkg cpage
npgs = set (at pgnum) (Just npage) pgs
nhdl = set gpages npgs hdl
modeChange ToViewAppendMode
modify (set hoodleModeState (ViewAppendState nhdl))
invalidateAll
defaultEventProcess (GotContextMenuSignal ctxtmenu) = processContextMenu ctxtmenu
defaultEventProcess ev = -- for debugging
do liftIO $ putStrLn "--- no default ---"
liftIO $ print ev
liftIO $ putStrLn "------------------"
return ()
-- |
menuEventProcess :: MenuEvent -> MainCoroutine ()
menuEventProcess MenuQuit = do
xstate <- get
liftIO $ putStrLn "MenuQuit called"
if view isSaved xstate
then liftIO $ mainQuit
else askQuitProgram
menuEventProcess MenuPreviousPage = changePage (\x->x-1)
menuEventProcess MenuNextPage = changePage (+1)
menuEventProcess MenuFirstPage = changePage (const 0)
menuEventProcess MenuLastPage = do
totalnumofpages <- (either (M.size. view gpages) (M.size . view gselAll)
. hoodleModeStateEither . view hoodleModeState) <$> get
changePage (const (totalnumofpages-1))
menuEventProcess MenuNewPageBefore = newPage PageBefore
menuEventProcess MenuNewPageAfter = newPage PageAfter
menuEventProcess MenuDeletePage = deleteCurrentPage
menuEventProcess MenuExportPageSVG = exportCurrentPageAsSVG
menuEventProcess MenuNew = askIfSave fileNew
menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF
menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG
menuEventProcess MenuLoadSVG = fileLoadSVG
menuEventProcess MenuLaTeX = fileLaTeX
menuEventProcess MenuUndo = undo
menuEventProcess MenuRedo = redo
menuEventProcess MenuOpen = askIfSave fileOpen
menuEventProcess MenuSave = fileSave
menuEventProcess MenuSaveAs = fileSaveAs
menuEventProcess MenuReload = fileReload
menuEventProcess MenuExport = fileExport
menuEventProcess MenuCut = cutSelection
menuEventProcess MenuCopy = copySelection
menuEventProcess MenuPaste = pasteToSelection
menuEventProcess MenuDelete = deleteSelection
menuEventProcess MenuZoomIn = pageZoomChangeRel ZoomIn
menuEventProcess MenuZoomOut = pageZoomChangeRel ZoomOut
menuEventProcess MenuNormalSize = pageZoomChange Original
menuEventProcess MenuPageWidth = pageZoomChange FitWidth
menuEventProcess MenuPageHeight = pageZoomChange FitHeight
menuEventProcess MenuHSplit = eitherSplit SplitHorizontal
menuEventProcess MenuVSplit = eitherSplit SplitVertical
menuEventProcess MenuDelCanvas = deleteCanvas
menuEventProcess MenuNewLayer = makeNewLayer
menuEventProcess MenuNextLayer = gotoNextLayer
menuEventProcess MenuPrevLayer = gotoPrevLayer
menuEventProcess MenuGotoLayer = startGotoLayerAt
menuEventProcess MenuDeleteLayer = deleteCurrentLayer
menuEventProcess MenuUseXInput = do
xstate <- get
b <- updateFlagFromToggleUI "UXINPUTA" doesUseXInput
let cmap = getCanvasInfoMap xstate
canvases = map (getDrawAreaFromBox) . M.elems $ cmap
if b
then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases
else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases
menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" doesSmoothScroll >> return ()
menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" doesUsePopUpMenu >> return ()
menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" doesEmbedImage >> return ()
menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return ()
menuEventProcess MenuRelaunch = liftIO $ relaunchApplication
menuEventProcess MenuColorPicker = colorPick
menuEventProcess MenuFullScreen = fullScreen
menuEventProcess MenuText = textInput
menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage
menuEventProcess MenuApplyToAllPages = do
xstate <- get
let bsty = view backgroundStyle xstate
let hdl = getHoodle xstate
pgs = view gpages hdl
changeBkg cpage =
let cbkg = view gbackground cpage
nbkg
| isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg
in bkg2RBkg bkg { bkg_style = convertBackgroundStyleToByteString bsty }
| otherwise = cbkg
in set gbackground nbkg cpage
npgs = fmap changeBkg pgs
nhdl = set gpages npgs hdl
modeChange ToViewAppendMode
modify (set hoodleModeState (ViewAppendState nhdl))
invalidateAll
menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m
-- |
colorPick :: MainCoroutine ()
colorPick = do mc <- colorPickerBox "Pen Color"
liftIO $ print mc
maybe (return ())
(\c->modify (penInfo.currentTool.penColor .~ c))
mc
-- |
colorConvert :: Color -> PenColor
colorConvert (Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0
-- |
colorPickerBox :: String -> MainCoroutine (Maybe PenColor)
colorPickerBox msg = do
xst <- get
let pcolor = view ( penInfo.currentTool.penColor) xst
modify (tempQueue %~ enqueue (action pcolor)) >> go
where
action pcolor =
Left . ActionOrder $
\_evhandler -> do
dialog <- colorSelectionDialogNew msg
csel <- colorSelectionDialogGetColor dialog
let (r,g,b,_a) = convertPenColorToRGBA pcolor
color = Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0))
colorSelectionSetCurrentColor csel color
res <- dialogRun dialog
mc <- case res of
ResponseOk -> do
clrsel <- colorSelectionDialogGetColor dialog
clr <- colorSelectionGetCurrentColor clrsel
return (Just (colorConvert clr))
_ -> return Nothing
widgetDestroy dialog
return (ColorChosen mc)
go = do r <- nextevent
case r of
ColorChosen mc -> return mc
_ -> go