hoodle-core-0.13: src/Hoodle/Coroutine/Minibuffer.hs
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Minibuffer
-- Copyright : (c) 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.Minibuffer where
import Control.Applicative ((<$>),(<*>))
import Control.Lens ((%~),view)
import Control.Monad.State (modify,get)
import Data.Foldable (Foldable(..),mapM_,forM_,toList)
import Data.Sequence (Seq,(|>),empty,singleton,viewl,ViewL(..))
import Graphics.UI.Gtk hiding (get,set)
import Graphics.Rendering.Cairo
--
import Control.Monad.Trans.Crtn.Queue (enqueue)
import Data.Hoodle.Simple
import Graphics.Hoodle.Render (renderStrk)
--
import Hoodle.Coroutine.Draw
import Hoodle.Device
import Hoodle.ModelAction.Pen (createNewStroke)
import Hoodle.Type.Canvas (defaultPenInfo, defaultPenWCS, penWidth)
import Hoodle.Type.Coroutine
import Hoodle.Type.Enum
import Hoodle.Type.Event
import Hoodle.Type.HoodleState
--
import Prelude hiding (length,mapM_)
drawMiniBufBkg :: Render ()
drawMiniBufBkg = do
setSourceRGBA 0.8 0.8 0.8 1
rectangle 0 0 500 50
fill
setSourceRGBA 0.95 0.85 0.5 1
rectangle 5 2 490 46
fill
setSourceRGBA 0 0 0 1
setLineWidth 1.0
rectangle 5 2 490 46
stroke
drawMiniBuf :: (Foldable t) => t Stroke -> Render ()
drawMiniBuf strks = drawMiniBufBkg >> mapM_ renderStrk strks
minibufDialog :: String -> MainCoroutine (Either () [Stroke])
minibufDialog msg = do
xst <- get
let dev = view deviceList xst
let ui = view gtkUIManager xst
agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->
case x of
[] -> error "No action group? "
y:_ -> return y )
uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) ->
return (castToToggleAction x) )
doesUseX11Ext <- liftIO $ toggleActionGetActive uxinputa
modify (tempQueue %~ enqueue (action dev doesUseX11Ext))
minibufInit
where
action dev _doesUseX11Ext = mkIOaction $ \evhandler -> do
dialog <- dialogNew
msgLabel <- labelNew (Just msg)
cvs <- drawingAreaNew
cvs `on` sizeRequest $ return (Requisition 500 50)
cvs `on` exposeEvent $ tryEvent $ do
drawwdw <- liftIO $ widgetGetDrawWindow cvs
liftIO (renderWithDrawable drawwdw drawMiniBufBkg)
(liftIO . evhandler . UsrEv . MiniBuffer . MiniBufferInitialized) drawwdw
cvs `on` buttonPressEvent $ tryEvent $ do
(mbtn,mp) <- getPointer dev
forM_ mp $ \p -> do
let pbtn = maybe PenButton1 id mbtn
case pbtn of
TouchButton -> return ()
_ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenDown pbtn p)
cvs `on` buttonReleaseEvent $ tryEvent $ do
(mbtn,mp) <- getPointer dev
forM_ mp $ \p -> do
let pbtn = maybe PenButton1 id mbtn
case pbtn of
TouchButton -> return ()
_ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenUp p)
cvs `on` motionNotifyEvent $ tryEvent $ do
(mbtn,mp) <- getPointer dev
forM_ mp $ \p -> do
let pbtn = maybe PenButton1 id mbtn
case pbtn of
TouchButton -> return ()
_ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenMove p)
{- if doesUseX11Ext
then widgetSetExtensionEvents cvs [ExtensionEventsAll]
else widgetSetExtensionEvents cvs [ExtensionEventsNone] -}
widgetAddEvents cvs [PointerMotionMask,Button1MotionMask]
--
vbox <- dialogGetUpper dialog
hbox <- hBoxNew False 0
boxPackStart hbox msgLabel PackNatural 0
boxPackStart vbox hbox PackNatural 0
boxPackStart vbox cvs PackNatural 0
_btnOk <- dialogAddButton dialog "Ok" ResponseOk
_btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel
_btnText <- dialogAddButton dialog "TextInput" (ResponseUser 1)
widgetShowAll dialog
res <- dialogRun dialog
widgetDestroy dialog
case res of
ResponseOk -> return (UsrEv (OkCancel True))
ResponseCancel -> return (UsrEv (OkCancel False))
ResponseUser 1 -> return (UsrEv ChangeDialog)
_ -> return (UsrEv (OkCancel False))
minibufInit :: MainCoroutine (Either () [Stroke])
minibufInit =
waitSomeEvent (\case MiniBuffer (MiniBufferInitialized _ )-> True ; _ -> False)
>>= (\case MiniBuffer (MiniBufferInitialized drawwdw) -> do
srcsfc <- liftIO (createImageSurface FormatARGB32 500 50)
tgtsfc <- liftIO (createImageSurface FormatARGB32 500 50)
liftIO $ renderWith srcsfc (drawMiniBuf empty)
liftIO $ invalidateMinibuf drawwdw srcsfc
minibufStart drawwdw (srcsfc,tgtsfc) empty
_ -> minibufInit)
invalidateMinibuf :: DrawWindow -> Surface -> IO ()
invalidateMinibuf drawwdw tgtsfc =
renderWithDrawable drawwdw $ do
setSourceSurface tgtsfc 0 0
setOperator OperatorSource
paint
minibufStart :: DrawWindow
-> (Surface,Surface) -- ^ (source surface, target surface)
-> Seq Stroke -> MainCoroutine (Either () [Stroke])
minibufStart drawwdw (srcsfc,tgtsfc) strks = do
r <- nextevent
case r of
UpdateCanvas cid -> do invalidateInBBox Nothing Efficient cid
minibufStart drawwdw (srcsfc,tgtsfc) strks
OkCancel True -> (return . Right) (toList strks)
OkCancel False -> (return . Right) []
ChangeDialog -> return (Left ())
MiniBuffer (MiniBufferPenDown PenButton1 pcoord) -> do
ps <- onestroke drawwdw (srcsfc,tgtsfc) (singleton pcoord)
let nstrks = strks |> mkstroke ps
liftIO $ renderWith srcsfc (drawMiniBuf nstrks)
minibufStart drawwdw (srcsfc,tgtsfc) nstrks
_ -> minibufStart drawwdw (srcsfc,tgtsfc) strks
onestroke :: DrawWindow -> (Surface,Surface) -> Seq PointerCoord
-> MainCoroutine (Seq PointerCoord)
onestroke drawwdw (srcsfc,tgtsfc) pcoords = do
r <- nextevent
case r of
MiniBuffer (MiniBufferPenMove pcoord) -> do
let newpcoords = pcoords |> pcoord
liftIO $ do drawstrokebit (srcsfc,tgtsfc) newpcoords
invalidateMinibuf drawwdw tgtsfc
onestroke drawwdw (srcsfc,tgtsfc) newpcoords
MiniBuffer (MiniBufferPenUp pcoord) -> return (pcoords |> pcoord)
_ -> onestroke drawwdw (srcsfc,tgtsfc) pcoords
drawstrokebit :: (Surface,Surface) -> Seq PointerCoord -> IO()
drawstrokebit (srcsfc,tgtsfc) ps =
renderWith tgtsfc $ do
setSourceSurface srcsfc 0 0
setOperator OperatorSource
paint
case viewl ps of
p :< ps' -> do
setOperator OperatorOver
setSourceRGBA 0.0 0.0 0.0 1.0
setLineWidth (view penWidth defaultPenWCS)
moveTo (pointerX p) (pointerY p)
mapM_ (uncurry lineTo . ((,)<$>pointerX<*>pointerY)) ps'
stroke
_ -> return ()
mkstroke :: Seq PointerCoord -> Stroke
mkstroke ps = let xyzs = fmap ((,,) <$> pointerX <*> pointerY <*> const 1.0) ps
pinfo = defaultPenInfo
in createNewStroke pinfo xyzs