{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.GUI.Reflect -- Copyright : (c) 2013, 2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.GUI.Reflect where import Control.Lens (view,Simple,Lens) import Control.Monad (liftM, when) import qualified Control.Monad.State as St import Control.Monad.Trans import Data.Array.MArray import Data.Foldable (forM_) import qualified Data.Map as M (lookup) import Data.Word import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set) -- import Hoodle.GUI.Menu import Hoodle.Coroutine.Draw import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement import Hoodle.Type.Predefined import Hoodle.Util import Hoodle.View.Coordinate -- import Debug.Trace -- | changeCurrentCanvasId :: CanvasId -> MainCoroutine HoodleState changeCurrentCanvasId cid = do xstate1 <- St.get maybe (return xstate1) (\xst -> do St.put xst return xst) (setCurrentCanvasId cid xstate1) reflectViewModeUI St.get -- | check current canvas id and new active canvas id and invalidate if it's -- changed. chkCvsIdNInvalidate :: CanvasId -> MainCoroutine () chkCvsIdNInvalidate cid = do currcid <- liftM (getCurrentCanvasId) St.get when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) blockWhile :: (GObjectClass w) => Maybe (ConnectId w) -> IO () -> IO () blockWhile msig act = maybe (return ()) signalBlock msig >> act >> maybe (return ()) signalUnblock msig -- | reflect view mode UI for current canvas info reflectViewModeUI :: MainCoroutine () reflectViewModeUI = do xstate <- St.get let cinfobox = view currentCanvasInfo xstate ui = view gtkUIManager xstate let mconnid = view (uiComponentSignalHandler.pageModeSignal) xstate agr <- liftIO $ uiManagerGetActionGroups ui ra1 <- maybe (error "reflectUI") return =<< liftIO (actionGroupGetAction (head agr) "ONEPAGEA") let wra1 = castToRadioAction ra1 unboxBiAct (pgmodupdate_s mconnid wra1) (pgmodupdate_c mconnid wra1) cinfobox return () where pgmodupdate_s mconnid wra1 _cinfo = do liftIO $ blockWhile mconnid $ Gtk.set wra1 [radioActionCurrentValue := 1 ] pgmodupdate_c mconnid wra1 _cinfo = do liftIO $ blockWhile mconnid $ Gtk.set wra1 [radioActionCurrentValue := 0 ] -- | reflectPenModeUI :: MainCoroutine () reflectPenModeUI = do reflectUIComponent penModeSignal "PENA" f reflectCursor where f xst = Just $ hoodleModeStateEither (view hoodleModeState xst) # either (\_ -> (penType2Int. Left .view (penInfo.penType)) xst) (\_ -> (penType2Int. Right .view (selectInfo.selectType)) xst) -- | reflectPenColorUI :: MainCoroutine () reflectPenColorUI = do reflectUIComponent penColorSignal "BLUEA" f reflectCursor where f xst = let mcolor = case view (penInfo.penType) xst of PenWork -> Just (view (penInfo.penSet.currPen.penColor) xst) HighlighterWork -> Just (view (penInfo.penSet.currHighlighter.penColor) xst) _ -> Nothing in fmap color2Int mcolor -- | reflectPenWidthUI :: MainCoroutine () reflectPenWidthUI = do reflectUIComponent penPointSignal "PENVERYFINEA" f reflectCursor where f xst = case view (penInfo.penType) xst of PenWork -> (Just . point2Int PenWork . view (penInfo.penSet.currPen.penWidth)) xst HighlighterWork -> let x = (Just . point2Int HighlighterWork . view (penInfo.penSet.currHighlighter.penWidth)) xst y = view (penInfo.penSet.currHighlighter.penWidth) xst in trace (" x= " ++ show x ++ " y = " ++ show y ) x EraserWork -> (Just . point2Int EraserWork . view (penInfo.penSet.currEraser.penWidth)) xst _ -> Nothing -- | reflectUIComponent :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction)) -> String -> (HoodleState -> Maybe Int) -> MainCoroutine () reflectUIComponent lnz name f = do xst <- St.get let ui = view gtkUIManager xst mconnid = view (uiComponentSignalHandler.lnz) xst agr <- liftIO $ uiManagerGetActionGroups ui Just pma <- liftIO $ actionGroupGetAction (head agr) name let wpma = castToRadioAction pma update xst wpma mconnid where update xst wpma mconnid = do (f xst) # (maybe (return ()) $ \v -> do doIOaction $ \_evhandler -> do blockWhile mconnid (Gtk.set wpma [radioActionCurrentValue := v ] ) return (UsrEv ActionOrdered) go) where go = do r <- nextevent case r of ActionOrdered -> return () _ -> go -- | reflectCursor :: MainCoroutine () reflectCursor = do xst <- St.get let useVCursor = view (settings.doesUseVariableCursor) xst let go = do r <- nextevent case r of ActionOrdered -> return () _ -> go if useVCursor then act xst >> go else do doIOaction $ \_ -> do let cinfobox = view currentCanvasInfo xst canvas = forBoth' unboxBiAct (view drawArea) cinfobox win <- widgetGetDrawWindow canvas postGUIAsync (drawWindowSetCursor win Nothing) return (UsrEv ActionOrdered) go where act xst = doIOaction $ \_ -> do let -- mcur = view cursorInfo xst cinfobox = view currentCanvasInfo xst canvas = forBoth' unboxBiAct (view drawArea) cinfobox cpn = PageNum $ forBoth' unboxBiAct (view currentPageNum) cinfobox pinfo = view penInfo xst pcolor = view (penSet . currPen . penColor) pinfo pwidth = view (penSet . currPen . penWidth) pinfo win <- widgetGetDrawWindow canvas dpy <- widgetGetDisplay canvas geometry <- forBoth' unboxBiAct (\c -> let arr = view (viewInfo.pageArrangement) c in makeCanvasGeometry cpn arr canvas ) cinfobox let p2c = desktop2Canvas geometry . page2Desktop geometry CvsCoord (x0,_y0) = p2c (cpn, PageCoord (0,0)) CvsCoord (x1,_y1) = p2c (cpn, PageCoord (pwidth,pwidth)) cursize = (x1-x0) (r,g,b,a) = case pcolor of ColorRGBA r' g' b' a' -> (r',g',b',a') _ -> maybe (0,0,0,1) id (M.lookup pcolor penColorRGBAmap) pb <- pixbufNew ColorspaceRgb True 8 maxCursorWidth maxCursorHeight let numPixels = maxCursorWidth*maxCursorHeight pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8)) forM_ [0..numPixels-1] $ \i -> do let cvt :: Double -> Word8 cvt x | x < 0.0039 = 0 | x > 0.996 = 255 | otherwise = fromIntegral (floor (x*256-1) `mod` 256 :: Int) if (fromIntegral (i `mod` maxCursorWidth)) < cursize && (fromIntegral (i `div` maxCursorWidth)) < cursize then do writeArray pbData (4*i) (cvt r) writeArray pbData (4*i+1) (cvt g) writeArray pbData (4*i+2) (cvt b) writeArray pbData (4*i+3) (cvt a) else do writeArray pbData (4*i) 0 writeArray pbData (4*i+1) 0 writeArray pbData (4*i+2) 0 writeArray pbData (4*i+3) 0 postGUIAsync . drawWindowSetCursor win . Just =<< cursorNewFromPixbuf dpy pb (floor cursize `div` 2) (floor cursize `div` 2) return (UsrEv ActionOrdered)