diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,30 @@ +0.5: 12 Dec 2011 + * First public release. basic pen operation, eraser operation, rectangular selection and file operations are implemented + +0.5.1: 16 Dec 2011 + * Use of configuration file '.hxournal'. Enable Use X Input menu. Dependency on xournal-parser and xournal-render is restricted to 0.2.0.* only + * checking gtk+-2.0 using pkg-config + +0.6: 18 Dec 2011 + * pdf background support. Annotate PDF menu is activated. preloading pdf background images + +0.6.0: 19 Dec 2011 + * some bug fixes (temporary yet) related to automatic scrollbar disappearing. Check when new, open, annotate pdf if xournal file is not saved yet. + +0.6.1: 25 Dec 2011 + * undo/redo support, double buffer rendering while scrolling + +0.6.2: 15 Jan 2012 + * layer support + +0.6.3: 24 Jan 2012 + * refine rendering while selection and scrolling. highlighter is implemented. Resizing selected strokes implemented + +0.6.4: 6 Feb 2012 + * lasso selection, continuous page view. + +0.6.5: 12 Feb 2012 + * pen button support, pen pressure support, using faster xoj parser + +0.6.6: 28 Feb 2012 + * scripting support, zoom in/out implemented. page functions are implemented diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Config where + +import Data.List +import Data.Maybe + +import Control.Applicative +import Control.Monad + + +import Distribution.Simple +import Distribution.Simple.BuildPaths + +import Distribution.Simple.Setup +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo + +import Distribution.System + +import System.Exit +import System.Process + +import System.FilePath +import System.Directory + +import System.Info + +myConfigHook :: UserHooks +myConfigHook = simpleUserHooks { + confHook = hookfunction +} + +hookfunction :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags + -> IO LocalBuildInfo +hookfunction x cflags = do + binfo <- confHook simpleUserHooks x cflags + let pkg_descr = localPkgDescr binfo + r_pbi <- config binfo + let newbinfo = + case r_pbi of + Just pbi -> binfo { localPkgDescr = + updatePackageDescription pbi pkg_descr } + Nothing -> do + let r_lib = library pkg_descr + case r_lib of + Just lib -> + let binfo2 = libBuildInfo lib + newlib = lib { libBuildInfo = binfo2 { cSources = [] }} + in binfo {localPkgDescr = pkg_descr {library = Just newlib}} + Nothing -> error "some library setting is wrong." + return newbinfo + + +config :: LocalBuildInfo -> IO (Maybe HookedBuildInfo) +config bInfo = do + (excode,out,err) <- readProcessWithExitCode "pkg-config" ["--cflags", "gtk+-2.0"] "" + incdirs <- case excode of + ExitSuccess -> return . extractIncDir $ out + _ -> error $ ("failure when running pkg-config --cflags gtk+-2.0 :\n" ++ err) + + + let Just lib = library . localPkgDescr $ bInfo + buildinfo = libBuildInfo lib + let hbi = emptyBuildInfo { extraLibs = extraLibs buildinfo + , extraLibDirs = extraLibDirs buildinfo + , includeDirs = incdirs ++ includeDirs buildinfo + } + let (r :: Maybe HookedBuildInfo) = Just (Just hbi, []) + -- putStrLn $ show hbi + return r + +-- data CFlagsOptionSet = CFlagsOptionSet { +-- includedirs :: [String] +-- others :: [String] +-- } + +extractIncDir :: String -> [String] +extractIncDir = (mapMaybe parseCFlags) . words + +parseCFlags :: String -> Maybe String +parseCFlags [] = Nothing +parseCFlags str@(x:xs) = + case x of + '-' -> if null xs + then Nothing + else let (y:ys) = xs + in case y of + 'I' -> Just ys + _ -> Nothing + _ -> Nothing diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2011, 2012, Ian-Woo Kim. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,9 @@ +#! /usr/bin/env runhaskell +> +> import Distribution.Simple +> import Distribution.PackageDescription +> import Config +> +> main :: IO () +> main = defaultMainWithHooks myConfigHook +> diff --git a/csrc/c_initdevice.c b/csrc/c_initdevice.c new file mode 100644 --- /dev/null +++ b/csrc/c_initdevice.c @@ -0,0 +1,66 @@ +#include +#include +#include + +void initdevice( int* core, int* stylus, int* eraser, + char* corepointername, char* stylusname, char* erasername + ) +{ + GList* dev_list; + GdkDevice* device; + dev_list = gdk_devices_list(); + (*stylus) = 0; + while (dev_list != NULL) { + // printf ("one device\n"); + device = (GdkDevice *)dev_list->data; + // printf(" %d : %s \n", device, device->name ); + if (device != gdk_device_get_core_pointer()) { + // #ifdef ENABLE_XINPUT_BUGFIX + gdk_device_set_axis_use(device, 0, GDK_AXIS_IGNORE); + gdk_device_set_axis_use(device, 1, GDK_AXIS_IGNORE); + // #endif + gdk_device_set_mode(device, GDK_MODE_SCREEN); + + // printf("This is xinput device %s \n", device -> name); + if( !strcmp (device->name, stylusname) ) { + // printf("got stylus\n"); + (*stylus) = (int) device; + } + if( !strcmp (device->name, erasername) ) { + // printf("got eraser\n"); + (*eraser) = (int) device; + } + } + else { + if( !strcmp (device->name, corepointername) ) { + // printf("got Core Pointer\n"); + (*core) = (int) device; + } + } + dev_list = dev_list->next; + } + +} + + +// void extEventCanvas( void* canvas ) { +/* Important note: we'd like ONLY the canvas window itself to receive + XInput events, while its child window in the GDK hierarchy (also + associated to the canvas widget) receives the core events. + This way on_canvas_... will get both types of events -- otherwise, + the proximity detection code in GDK is broken and we'll lose core + events. + + Up to GTK+ 2.10, gtk_widget_set_extension_events() only sets + extension events for the widget's main window itself; in GTK+ 2.11 + also traverses GDK child windows that belong to the widget + and sets their extension events too. We want to avoid that. + So we use gdk_input_set_extension_events() directly on the canvas. +*/ + +/* // this causes GTK+ 2.11 bugs + gtk_widget_set_extension_events(GTK_WIDGET(canvas),GDK_EXTENSION_EVENTS_ALL); +*/ + +// gdk_input_set_extension_events(GTK_WIDGET(canvas)->window, GDK_POINTER_MOTION_MASK | GDK_BUTTON_MOTION_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK, GDK_EXTENSION_EVENTS_ALL); +//} diff --git a/csrc/c_initdevice.h b/csrc/c_initdevice.h new file mode 100644 --- /dev/null +++ b/csrc/c_initdevice.h @@ -0,0 +1,6 @@ +#include +#include + +void initdevice( int* core, int* stylus, int* eraser, + char* corepointername, char* stylusname, char* erasername ); + diff --git a/csrc/template-hsc-gtk2hs.h b/csrc/template-hsc-gtk2hs.h new file mode 100644 --- /dev/null +++ b/csrc/template-hsc-gtk2hs.h @@ -0,0 +1,17 @@ +#ifndef _TEMPLATE_HSC_GTK2HS_H_ +#define _TEMPLATE_HSC_GTK2HS_H_ + +#include + +#define hsc_gtk2hs_type(t) \ + if ((t)(int)(t)1.4 == (t)1.4) \ + printf ("%s%" G_GSIZE_FORMAT, \ + (t)(-1) < (t)0 ? "Int" : "Word", \ + sizeof (t) * 8); \ + else \ + printf ("%s", \ + sizeof (t) > sizeof (double) ? "LDouble" : \ + sizeof (t) == sizeof (double) ? "Double" : \ + "Float"); + +#endif diff --git a/hoodle-core.cabal b/hoodle-core.cabal new file mode 100644 --- /dev/null +++ b/hoodle-core.cabal @@ -0,0 +1,154 @@ +Name: hoodle-core +Version: 0.7 +Synopsis: Core library for hoodle +Description: Hoodle is a pen notetaking program written in haskell. + hoodle-core is the core library written in haskell and + using gtk2hs +Homepage: http://ianwookim.org/hoodle +License: BSD3 +License-file: LICENSE +Author: Ian-Woo Kim +Maintainer: Ian-Woo Kim +Category: Application +Tested-with: GHC == 7.0 +Build-Type: Custom +Cabal-Version: >= 1.8 +data-files: template/*.html.st + resource/*.png + CHANGES + Config.hs +Source-repository head + type: git + location: http://www.github.com/wavewave/hoodle-core + +Flag Poppler + Description: Enable poppler support + Default: False + + +Library + hs-source-dirs: src + ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind + ghc-prof-options: -caf-all -auto-all + + if flag(poppler) + Build-Depends: base == 4.*, + mtl == 2.*, + directory == 1.*, + filepath == 1.*, + strict == 0.3.*, + gtk == 0.12.*, + cairo == 0.12.*, + attoparsec == 0.10.*, + coroutine-object >= 0.0.999 && < 0.2, + transformers == 0.3.*, + transformers-free == 1.0.*, + hoodle-types >= 0.0.999 && < 0.2, + hoodle-parser >= 0.0.999 && < 0.2, + xournal-parser >= 0.4.999 && < 0.6, + hoodle-render >= 0.0.999 && < 0.2, + hoodle-builder >= 0.0.999 && < 0.2, + containers == 0.4.*, + template-haskell == 2.*, + bytestring == 0.9.*, + lens >= 2.4 && < 2.7, + configurator == 0.2.*, + poppler == 0.12.*, + time >= 1.2 && < 1.5, + TypeCompose == 0.9.*, + Diff == 0.1.*, + dyre >= 0.8.11, + cereal == 0.3.5.*, + base64-bytestring == 0.1.*, + old-locale >= 1.0 + else + Build-Depends: base == 4.*, + mtl == 2.*, + directory == 1.*, + filepath == 1.*, + strict == 0.3.*, + gtk == 0.12.*, + cairo == 0.12.*, + attoparsec == 0.10.*, + coroutine-object >= 0.0.999 && < 0.2, + transformers == 0.3.*, + transformers-free == 1.0.*, + hoodle-types >= 0.0.999 && < 0.2 , + hoodle-parser == 0.0.999 && < 0.2, + xournal-parser >= 0.4.999 && < 0.6, + hoodle-render >= 0.0.999 && < 0.2, + hoodle-builder >= 0.0.999 && < 0.2, + containers == 0.4.*, + template-haskell == 2.*, + bytestring == 0.9.*, + lens >= 2.4 && < 2.7, + configurator == 0.2.*, + time >= 1.2 && < 1.5, + TypeCompose == 0.9.*, + Diff == 0.1.*, + dyre >= 0.8.11, + cereal == 0.3.5.*, + base64-bytestring == 0.1.*, + old-locale >= 1.0 + Exposed-Modules: + Hoodle.Accessor + Hoodle.Config + Hoodle.Coroutine + Hoodle.Coroutine.Callback + Hoodle.Coroutine.Commit + Hoodle.Coroutine.Default + Hoodle.Coroutine.Draw + Hoodle.Coroutine.Eraser + Hoodle.Coroutine.EventConnect + Hoodle.Coroutine.File + Hoodle.Coroutine.Highlighter + Hoodle.Coroutine.Layer + Hoodle.Coroutine.Mode + Hoodle.Coroutine.Page + Hoodle.Coroutine.Pen + Hoodle.Coroutine.Scroll + Hoodle.Coroutine.Select + Hoodle.Coroutine.Select.Clipboard + Hoodle.Coroutine.Window + Hoodle.Device + Hoodle.GUI + Hoodle.GUI.Menu + Hoodle.ModelAction.Adjustment + Hoodle.ModelAction.Clipboard + Hoodle.ModelAction.Eraser + Hoodle.ModelAction.File + Hoodle.ModelAction.Layer + Hoodle.ModelAction.Page + Hoodle.ModelAction.Pen + Hoodle.ModelAction.Select + Hoodle.ModelAction.Window + Hoodle.Script + Hoodle.Script.Coroutine + Hoodle.Script.Hook + Hoodle.Type + Hoodle.Type.Alias + Hoodle.Type.Canvas + Hoodle.Type.Clipboard + Hoodle.Type.Coroutine + Hoodle.Type.Enum + Hoodle.Type.Event + Hoodle.Type.PageArrangement + Hoodle.Type.Predefined + Hoodle.Type.Undo + Hoodle.Type.Window + Hoodle.Type.HoodleState + Hoodle.Util + Hoodle.Util.Verbatim + Hoodle.View.Coordinate + Hoodle.View.Draw + Other-Modules: + Paths_hoodle_core + c-sources: + csrc/c_initdevice.c + include-dirs: csrc + install-includes: + csrc/c_initdevice.h + csrc/template-hsc-gtk2hs.h + cc-options: -Wno-pointer-to-int-cast + if flag(poppler) + cpp-options: -DPOPPLER diff --git a/resource/black.png b/resource/black.png new file mode 100644 Binary files /dev/null and b/resource/black.png differ diff --git a/resource/blue.png b/resource/blue.png new file mode 100644 Binary files /dev/null and b/resource/blue.png differ diff --git a/resource/default-pen.png b/resource/default-pen.png new file mode 100644 Binary files /dev/null and b/resource/default-pen.png differ diff --git a/resource/eraser.png b/resource/eraser.png new file mode 100644 Binary files /dev/null and b/resource/eraser.png differ diff --git a/resource/fullscreen.png b/resource/fullscreen.png new file mode 100644 Binary files /dev/null and b/resource/fullscreen.png differ diff --git a/resource/gray.png b/resource/gray.png new file mode 100644 Binary files /dev/null and b/resource/gray.png differ diff --git a/resource/green.png b/resource/green.png new file mode 100644 Binary files /dev/null and b/resource/green.png differ diff --git a/resource/hand.png b/resource/hand.png new file mode 100644 Binary files /dev/null and b/resource/hand.png differ diff --git a/resource/highlighter.png b/resource/highlighter.png new file mode 100644 Binary files /dev/null and b/resource/highlighter.png differ diff --git a/resource/lasso.png b/resource/lasso.png new file mode 100644 Binary files /dev/null and b/resource/lasso.png differ diff --git a/resource/lightblue.png b/resource/lightblue.png new file mode 100644 Binary files /dev/null and b/resource/lightblue.png differ diff --git a/resource/lightgreen.png b/resource/lightgreen.png new file mode 100644 Binary files /dev/null and b/resource/lightgreen.png differ diff --git a/resource/magenta.png b/resource/magenta.png new file mode 100644 Binary files /dev/null and b/resource/magenta.png differ diff --git a/resource/medium.png b/resource/medium.png new file mode 100644 Binary files /dev/null and b/resource/medium.png differ diff --git a/resource/orange.png b/resource/orange.png new file mode 100644 Binary files /dev/null and b/resource/orange.png differ diff --git a/resource/pencil.png b/resource/pencil.png new file mode 100644 Binary files /dev/null and b/resource/pencil.png differ diff --git a/resource/rect-select.png b/resource/rect-select.png new file mode 100644 Binary files /dev/null and b/resource/rect-select.png differ diff --git a/resource/recycled.png b/resource/recycled.png new file mode 100644 Binary files /dev/null and b/resource/recycled.png differ diff --git a/resource/red.png b/resource/red.png new file mode 100644 Binary files /dev/null and b/resource/red.png differ diff --git a/resource/ruler.png b/resource/ruler.png new file mode 100644 Binary files /dev/null and b/resource/ruler.png differ diff --git a/resource/shapes.png b/resource/shapes.png new file mode 100644 Binary files /dev/null and b/resource/shapes.png differ diff --git a/resource/stretch.png b/resource/stretch.png new file mode 100644 Binary files /dev/null and b/resource/stretch.png differ diff --git a/resource/text-tool.png b/resource/text-tool.png new file mode 100644 Binary files /dev/null and b/resource/text-tool.png differ diff --git a/resource/thick.png b/resource/thick.png new file mode 100644 Binary files /dev/null and b/resource/thick.png differ diff --git a/resource/thin.png b/resource/thin.png new file mode 100644 Binary files /dev/null and b/resource/thin.png differ diff --git a/resource/white.png b/resource/white.png new file mode 100644 Binary files /dev/null and b/resource/white.png differ diff --git a/resource/xournal.png b/resource/xournal.png new file mode 100644 Binary files /dev/null and b/resource/xournal.png differ diff --git a/resource/yellow.png b/resource/yellow.png new file mode 100644 Binary files /dev/null and b/resource/yellow.png differ diff --git a/src/Hoodle/Accessor.hs b/src/Hoodle/Accessor.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Accessor.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Accessor +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Accessor where + +import Control.Applicative +import Control.Category +import Control.Lens +import Control.Monad hiding (mapM_) +import qualified Control.Monad.State as St hiding (mapM_) +import Control.Monad.Trans +import Data.Foldable +import qualified Data.IntMap as M +import Graphics.UI.Gtk hiding (get,set) +import qualified Graphics.UI.Gtk as Gtk (set) +-- from hoodle-platform +import Data.Hoodle.Generic +import Data.Hoodle.Select +import Graphics.Hoodle.Render.Type +-- from this package +import Hoodle.ModelAction.Layer +import Hoodle.Type +import Hoodle.Type.Alias +import Hoodle.View.Coordinate +import Hoodle.Type.PageArrangement +-- +import Prelude hiding ((.),id,mapM_) + +-- | update state +updateXState :: (HoodleState -> MainCoroutine HoodleState) -> MainCoroutine () +updateXState action = St.put =<< action =<< St.get + +-- | +getPenType :: MainCoroutine PenType +getPenType = view (penInfo.penType) <$> St.get + +-- | +getCurrentPageCurr :: MainCoroutine (Page EditMode) +getCurrentPageCurr = do + xstate <- St.get + let hdlmodst = view hoodleModeState xstate + cinfobox = view currentCanvasInfo xstate + return $ fmap4CvsInfoBox (\x->getCurrentPageFromHoodleModeState x hdlmodst) cinfobox + + +{- case cinfobox of + CanvasInfoBox cinfo -> -} + +-- | +getCurrentPageCvsId :: CanvasId -> MainCoroutine (Page EditMode) +getCurrentPageCvsId cid = do + xstate <- St.get + let hdlmodst = view hoodleModeState xstate + cinfobox = getCanvasInfo cid xstate + return $ fmap4CvsInfoBox (\c->getCurrentPageFromHoodleModeState c hdlmodst) cinfobox + + +{- case cinfobox of + CanvasInfoBox cinfo -> return -} + +-- | +getCurrentPageEitherFromHoodleModeState :: + (ViewMode a) => + CanvasInfo a -> HoodleModeState -> Either (Page EditMode) (Page SelectMode) +getCurrentPageEitherFromHoodleModeState cinfo hdlmodst = + let cpn = view currentPageNum cinfo + page = getCurrentPageFromHoodleModeState cinfo hdlmodst + in case hdlmodst of + ViewAppendState _hdl -> Left page + SelectState thdl -> + case view gselSelected thdl of + Nothing -> Left page + Just (n,tpage) -> if cpn == n + then Right tpage + else Left page + +-- | +rItmsInCurrLyr :: MainCoroutine [RItem] +rItmsInCurrLyr = do + page <- getCurrentPageCurr + let (mcurrlayer, _currpage) = getCurrentLayerOrSet page + currlayer = maybe (error "rItmsInCurrLyr") id mcurrlayer + (return . view gitems) currlayer + +-- | +otherCanvas :: HoodleState -> [Int] +otherCanvas = M.keys . getCanvasInfoMap + +-- | +changeCurrentCanvasId :: CanvasId -> MainCoroutine HoodleState +changeCurrentCanvasId cid = do + xstate1 <- St.get + maybe (return xstate1) + (\xst -> do St.put xst + return xst) + (setCurrentCanvasId cid xstate1) + xst <- St.get + let cinfo = view currentCanvasInfo xst + ui = view gtkUIManager xst + reflectUI ui cinfo + return xst + +-- | reflect UI for current canvas info +reflectUI :: UIManager -> CanvasInfoBox -> MainCoroutine () +reflectUI ui cinfobox = do + xstate <- St.get + let mconnid = view pageModeSignal xstate + liftIO $ maybe (return ()) signalBlock mconnid + agr <- liftIO $ uiManagerGetActionGroups ui + Just ra1 <- liftIO $ actionGroupGetAction (head agr) "ONEPAGEA" + selectBoxAction (fsingle ra1) (fcont ra1) cinfobox + liftIO $ maybe (return ()) signalUnblock mconnid + return () + where fsingle ra1 _cinfo = do + let wra1 = castToRadioAction ra1 + liftIO $ Gtk.set wra1 [radioActionCurrentValue := 1 ] + fcont ra1 _cinfo = do + liftIO $ Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 0 ] + +-- | +printViewPortBBox :: CanvasId -> MainCoroutine () +printViewPortBBox cid = do + cvsInfo <- return . getCanvasInfo cid =<< St.get + liftIO $ putStrLn $ show (unboxGet (viewInfo.pageArrangement.viewPortBBox) cvsInfo) + +-- | +printViewPortBBoxAll :: MainCoroutine () +printViewPortBBoxAll = do + xstate <- St.get + let cmap = getCanvasInfoMap xstate + cids = M.keys cmap + mapM_ printViewPortBBox cids + +-- | +printViewPortBBoxCurr :: MainCoroutine () +printViewPortBBoxCurr = do + cvsInfo <- return . view currentCanvasInfo =<< St.get + liftIO $ putStrLn $ show (unboxGet (viewInfo.pageArrangement.viewPortBBox) cvsInfo) + +-- | +printModes :: CanvasId -> MainCoroutine () +printModes cid = do + cvsInfo <- return . getCanvasInfo cid =<< St.get + liftIO $ printCanvasMode cid cvsInfo + +-- | +printCanvasMode :: CanvasId -> CanvasInfoBox -> IO () +printCanvasMode cid cvsInfo = do + let zmode = unboxGet (viewInfo.zoomMode) cvsInfo + f :: PageArrangement a -> String + f (SingleArrangement _ _ _) = "SingleArrangement" + f (ContinuousArrangement _ _ _ _) = "ContinuousArrangement" + g :: CanvasInfo a -> String + g cinfo = f . view (viewInfo.pageArrangement) $ cinfo + arrmode :: String + arrmode = boxAction g cvsInfo + incid = unboxGet canvasId cvsInfo + putStrLn $ show (cid,incid,zmode,arrmode) + +-- | +printModesAll :: MainCoroutine () +printModesAll = do + xstate <- St.get + let cmap = getCanvasInfoMap xstate + cids = M.keys cmap + mapM_ printModes cids + +-- | +getCanvasGeometryCvsId :: CanvasId -> HoodleState -> IO CanvasGeometry +getCanvasGeometryCvsId cid xstate = do + let cinfobox = getCanvasInfo cid xstate + cpn = PageNum . unboxGet currentPageNum $ cinfobox + canvas = unboxGet drawArea cinfobox + fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry + fsingle = flip (makeCanvasGeometry cpn) canvas + . view (viewInfo.pageArrangement) + boxAction fsingle cinfobox + +-- | +getGeometry4CurrCvs :: HoodleState -> IO CanvasGeometry +getGeometry4CurrCvs xstate = do + let cinfobox = view currentCanvasInfo xstate + cpn = PageNum . unboxGet currentPageNum $ cinfobox + canvas = unboxGet drawArea cinfobox + fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry + fsingle = flip (makeCanvasGeometry cpn) canvas + . view (viewInfo.pageArrangement) + boxAction fsingle cinfobox + +{- +-- | +getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox] +getAllStrokeBBoxInCurrentPage = do + page <- getCurrentPageCurr + return [ s | l <- toList (view glayers page) + , s <- (catMaybes . map findStrkInRItem . view gitems) l ] + +-} + +{- +-- | +getAllStrokeBBoxInCurrentLayer :: MainCoroutine [StrokeBBox] +getAllStrokeBBoxInCurrentLayer = do + page <- getCurrentPageCurr + let (mcurrlayer, _currpage) = getCurrentLayerOrSet page + currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer + (return . catMaybes . map findStrkInRItem . view gitems) currlayer +-} + + diff --git a/src/Hoodle/Config.hs b/src/Hoodle/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Config.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Config +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Config where + +import Control.Monad +import Data.Configurator as C +import Data.Configurator.Types +import System.Environment +import System.Directory +import System.FilePath +import Control.Concurrent + +emptyConfigString :: String +emptyConfigString = "\n#config file for hoodle \n " + +loadConfigFile :: IO Config +loadConfigFile = do + homepath <- getEnv "HOME" + let dothoodle = homepath ".hoodle" + b <- doesFileExist dothoodle + when (not b) $ do + writeFile dothoodle emptyConfigString + threadDelay 1000000 + config <- load [Required "$(HOME)/.hoodle"] + return config + +getMaxUndo :: Config -> IO (Maybe Int) +getMaxUndo c = C.lookup c "maxundo" + +getPenDevConfig :: Config -> IO (Maybe String, Maybe String,Maybe String) +getPenDevConfig c = do + mcore <- C.lookup c "core" + mstylus <- C.lookup c "stylus" + meraser <- C.lookup c "eraser" + return (mcore,mstylus,meraser) + +getXInputConfig :: Config -> IO Bool +getXInputConfig c = do + (mxinput :: Maybe String) <- C.lookup c "xinput" + case mxinput of + Nothing -> return False + Just str -> case str of + "true" -> return True + "false" -> return False + _ -> error "cannot understand xinput in configfile" + +{- +getNetworkInfo :: Config -> IO (Maybe HoodleClipClientConfiguration) +getNetworkInfo c = do + (mserver :: Maybe String) <- C.lookup c "network.server" + (mclient :: Maybe String) <- C.lookup c "network.client" + return (HoodleClipClientConfiguration <$> mserver <*> mclient) +-} diff --git a/src/Hoodle/Coroutine.hs b/src/Hoodle/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- + +module Hoodle.Coroutine +( module Hoodle.Coroutine.EventConnect +, module Hoodle.Coroutine.Default +, module Hoodle.Coroutine.Pen +, module Hoodle.Coroutine.Eraser +, module Hoodle.Coroutine.Highlighter +) where + +import Hoodle.Coroutine.EventConnect +import Hoodle.Coroutine.Default +import Hoodle.Coroutine.Pen +import Hoodle.Coroutine.Eraser +import Hoodle.Coroutine.Highlighter + diff --git a/src/Hoodle/Coroutine/Callback.hs b/src/Hoodle/Coroutine/Callback.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Callback.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Callback +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Callback where + +import Control.Concurrent +import Control.Exception +import Data.Time +import System.Environment +import System.FilePath +import System.Locale +import System.IO +import System.Exit +-- +import Control.Monad.Trans.Crtn.Driver +import qualified Control.Monad.Trans.Crtn.EventHandler as E +-- +import Prelude hiding (catch) + +eventHandler :: MVar (Maybe (Driver e IO ())) -> e -> IO () +eventHandler evar ev = E.eventHandler evar ev `catch` allexceptionproc + + -- `catches` [Handler errorcall, Handler patternerr] + +allexceptionproc :: SomeException -> IO () +allexceptionproc e = do errorlog (show e) + exitFailure + + +errorcall :: ErrorCall -> IO () +errorcall e = errorlog (show e) + +patternerr :: PatternMatchFail -> IO () +patternerr e = errorlog (show e) + +errorlog :: String -> IO () +errorlog str = do + homepath <- getEnv "HOME" + outh <- openFile (homepath ".hoodle.d" "error.log") AppendMode + utctime <- getCurrentTime + let timestr = formatTime defaultTimeLocale "%F %H:%M:%S %Z" utctime + hPutStr outh (timestr ++ " : " ) + hPutStrLn outh str + hClose outh + diff --git a/src/Hoodle/Coroutine/Commit.hs b/src/Hoodle/Coroutine/Commit.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Commit.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Commit +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Commit where + +-- import Data.Label +import Control.Lens +import Control.Monad.Trans +import Control.Monad.State +-- from this package +import Hoodle.Coroutine.Draw +import Hoodle.ModelAction.File +import Hoodle.ModelAction.Page +import Hoodle.Type.Coroutine +import Hoodle.Type.HoodleState +import Hoodle.Type.Undo + +-- | save state and add the current status in undo history + +commit :: HoodleState -> MainCoroutine () +commit xstate = do + let ui = view gtkUIManager xstate + liftIO $ toggleSave ui True + let hdlmodst = view hoodleModeState xstate + undotable = view undoTable xstate + undotable' = addToUndo undotable hdlmodst + xstate' = set isSaved False + . set undoTable undotable' + $ xstate + put xstate' + +-- | + +commit_ :: MainCoroutine () +commit_ = get >>= commit + +-- | + +undo :: MainCoroutine () +undo = do + xstate <- get + let utable = view undoTable xstate + case getPrevUndo utable of + Nothing -> liftIO $ putStrLn "no undo item yet" + Just (hdlmodst1,newtable) -> do + hdlmodst <- liftIO $ resetHoodleModeStateBuffers hdlmodst1 + put . set hoodleModeState hdlmodst + . set undoTable newtable + =<< (liftIO (updatePageAll hdlmodst xstate)) + invalidateAll + +-- | + +redo :: MainCoroutine () +redo = do + xstate <- get + let utable = view undoTable xstate + case getNextUndo utable of + Nothing -> liftIO $ putStrLn "no redo item" + Just (hdlmodst1,newtable) -> do + hdlmodst <- liftIO $ resetHoodleModeStateBuffers hdlmodst1 + put . set hoodleModeState hdlmodst + . set undoTable newtable + =<< (liftIO (updatePageAll hdlmodst xstate)) + invalidateAll + +-- | + +clearUndoHistory :: MainCoroutine () +clearUndoHistory = do + xstate <- get + put . set undoTable (emptyUndo 1) $ xstate + + + + + diff --git a/src/Hoodle/Coroutine/Default.hs b/src/Hoodle/Coroutine/Default.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Default.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Default +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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.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.Object +import Control.Monad.Trans.Crtn.Logger.Simple +import Data.Hoodle.Select +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Generic +-- from this package +import Hoodle.Accessor +import Hoodle.Coroutine.Callback +import Hoodle.Coroutine.Commit +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.Mode +import Hoodle.Coroutine.Window +import Hoodle.Device +import Hoodle.GUI.Menu +import Hoodle.ModelAction.File +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 + -> IO (EventVar,HoodleState,UIManager,VBox) +initCoroutine devlst window mfname mhook maxundo = 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 hookSet mhook + . set undoTable (emptyUndo maxundo) + . set frameState wconf' + . set rootWindow cvs $ st4 + + st6 <- getFileContent mfname st5 + vbox <- vBoxNew False 0 + let startingXstate = set rootContainer (castToBox vbox) st6 + 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 + 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 +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 + -- put . set (penInfo.penType) pm =<< get + modify (penInfo.penType .~ pm) + modeChange ToViewAppendMode + Right sm -> do + 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 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 MenuNew = askIfSave fileNew +menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF +menuEventProcess MenuLoadImage = fileLoadImage +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 + let ui = view gtkUIManager xstate + agr <- liftIO ( uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group? " + y:_ -> return y ) + uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA") + >>= maybe (error "MenuUseXInput") (return . castToToggleAction) + b <- liftIO $ toggleActionGetActive uxinputa + 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 MenuPressureSensitivity = updateXState pressSensAction + where pressSensAction xstate = do + let ui = view gtkUIManager xstate + agr <- liftIO ( uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group? " + y:_ -> return y ) + pressrsensa <- liftIO (actionGroupGetAction agr "PRESSRSENSA") + >>= maybe (error "MenuPressureSensitivity") + (return . castToToggleAction) + b <- liftIO $ toggleActionGetActive pressrsensa + return (set (penInfo.variableWidthPen) b xstate) +menuEventProcess MenuRelaunch = liftIO $ relaunchApplication +menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m + + + diff --git a/src/Hoodle/Coroutine/Draw.hs b/src/Hoodle/Coroutine/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Draw.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Draw +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Draw where + +-- from other packages +import Control.Applicative +import Control.Category +import qualified Data.IntMap as M +import Control.Lens +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +-- import Data.Label +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk hiding (get,set) +-- from hoodle-platform +import Data.Hoodle.BBox +-- from this package +import Hoodle.Accessor +import Hoodle.Type.Alias +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.PageArrangement +import Hoodle.Type.HoodleState +import Hoodle.View.Draw +-- +import Prelude hiding ((.),id) + +-- | +data DrawingFunctionSet = + DrawingFunctionSet { singleEditDraw :: DrawingFunction SinglePage EditMode + , singleSelectDraw :: DrawingFunction SinglePage SelectMode + , contEditDraw :: DrawingFunction ContinuousPage EditMode + , contSelectDraw :: DrawingFunction ContinuousPage SelectMode + } + +-- | +invalidateGeneral :: CanvasId -> Maybe BBox + -> DrawingFunction SinglePage EditMode + -> DrawingFunction SinglePage SelectMode + -> DrawingFunction ContinuousPage EditMode + -> DrawingFunction ContinuousPage SelectMode + -> MainCoroutine () +invalidateGeneral cid mbbox drawf drawfsel drawcont drawcontsel = do + xst <- get + selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst + where fsingle :: HoodleState -> CanvasInfo SinglePage -> MainCoroutine () + fsingle xstate cvsInfo = do + let cpn = PageNum . view currentPageNum $ cvsInfo + isCurrentCvs = cid == getCurrentCanvasId xstate + epage = getCurrentPageEitherFromHoodleModeState cvsInfo (view hoodleModeState xstate) + case epage of + Left page -> do + liftIO (unSinglePageDraw drawf isCurrentCvs + <$> view drawArea <*> pure (cpn,page) + <*> view viewInfo <*> pure mbbox $ cvsInfo ) + Right tpage -> do + liftIO (unSinglePageDraw drawfsel isCurrentCvs + <$> view drawArea <*> pure (cpn,tpage) + <*> view viewInfo <*> pure mbbox $ cvsInfo ) + fcont :: HoodleState -> CanvasInfo ContinuousPage -> MainCoroutine () + fcont xstate cvsInfo = do + let hdlmodst = view hoodleModeState xstate + isCurrentCvs = cid == getCurrentCanvasId xstate + case hdlmodst of + ViewAppendState hdl -> do + liftIO (unContPageDraw drawcont isCurrentCvs cvsInfo mbbox hdl) + SelectState thdl -> + liftIO (unContPageDraw drawcontsel isCurrentCvs cvsInfo mbbox thdl) + +-- | + +invalidateOther :: MainCoroutine () +invalidateOther = do + xstate <- get + let currCvsId = getCurrentCanvasId xstate + cinfoMap = getCanvasInfoMap xstate + keys = M.keys cinfoMap + mapM_ invalidate (filter (/=currCvsId) keys) + +-- | invalidate clear + +invalidate :: CanvasId -> MainCoroutine () +invalidate = invalidateInBBox Nothing + +-- | + +invalidateInBBox :: Maybe BBox -- ^ desktop coord + -> CanvasId -> MainCoroutine () +invalidateInBBox mbbox cid = do + invalidateGeneral cid mbbox + drawPageClearly drawPageSelClearly drawContHoodleClearly drawContHoodleSelClearly + +-- | + +invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate + -> MainCoroutine () +invalidateAllInBBox mbbox = do + xstate <- get + let cinfoMap = getCanvasInfoMap xstate + keys = M.keys cinfoMap + forM_ keys (invalidateInBBox mbbox) + +-- | + +invalidateAll :: MainCoroutine () +invalidateAll = invalidateAllInBBox Nothing + +-- | Invalidate Current canvas + +invalidateCurrent :: MainCoroutine () +invalidateCurrent = invalidate . getCurrentCanvasId =<< get + +-- | Drawing temporary gadgets + +invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine () +invalidateTemp cid tempsurface rndr = do + xst <- get + selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst + where fsingle xstate cvsInfo = do + let canvas = view drawArea cvsInfo + pnum = PageNum . view currentPageNum $ cvsInfo + geometry <- liftIO $ getCanvasGeometryCvsId cid xstate + win <- liftIO $ widgetGetDrawWindow canvas + let xformfunc = cairoXform4PageCoordinate geometry pnum + liftIO $ renderWithDrawable win $ do + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint + xformfunc + rndr + +-- | Drawing temporary gadgets with coordinate based on base page + +invalidateTempBasePage :: CanvasId -> Surface -> PageNum -> Render () + -> MainCoroutine () +invalidateTempBasePage cid tempsurface pnum rndr = do + xst <- get + selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst + where fsingle xstate cvsInfo = do + let canvas = view drawArea cvsInfo + geometry <- liftIO $ getCanvasGeometryCvsId cid xstate + win <- liftIO $ widgetGetDrawWindow canvas + let xformfunc = cairoXform4PageCoordinate geometry pnum + liftIO $ renderWithDrawable win $ do + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint + xformfunc + rndr + +-- | Drawing using layer buffer + +invalidateWithBuf :: CanvasId -> MainCoroutine () +invalidateWithBuf = invalidateWithBufInBBox Nothing + +-- | Drawing using layer buffer in BBox + +invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () +invalidateWithBufInBBox mbbox cid = + invalidateGeneral cid mbbox drawBuf drawSelBuf drawContHoodleBuf drawContHoodleSelClearly + +-- | check current canvas id and new active canvas id and invalidate if it's changed. + +chkCvsIdNInvalidate :: CanvasId -> MainCoroutine () +chkCvsIdNInvalidate cid = do + currcid <- liftM (getCurrentCanvasId) get + when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) + diff --git a/src/Hoodle/Coroutine/Eraser.hs b/src/Hoodle/Coroutine/Eraser.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Eraser.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Eraser +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Eraser where + +import Control.Category +-- import Data.Label +import qualified Data.IntMap as IM +import Control.Lens +import Control.Monad.State +import qualified Control.Monad.State as St +import Graphics.UI.Gtk hiding (get,set,disconnect) +-- +import Data.Hoodle.Generic +import Data.Hoodle.BBox +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type.Item +import Graphics.Hoodle.Render.Util.HitTest +-- +import Hoodle.Type.Event +import Hoodle.Type.Coroutine +import Hoodle.Type.Canvas +import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement +import Hoodle.Device +import Hoodle.View.Coordinate +import Hoodle.Coroutine.EventConnect +import Hoodle.Coroutine.Draw +import Hoodle.Coroutine.Commit +import Hoodle.Accessor +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Eraser +import Hoodle.ModelAction.Layer +import Hoodle.Coroutine.Pen +-- +import Prelude hiding ((.), id) + +-- | +eraserStart :: CanvasId + -> PointerCoord + -> MainCoroutine () +eraserStart cid = commonPenStart eraserAction cid + where eraserAction _cinfo pnum geometry (cidup,cidmove) (x,y) = do + itms <- rItmsInCurrLyr + eraserProcess cid pnum geometry cidup cidmove itms (x,y) + +-- | + +eraserProcess :: CanvasId + -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea -> ConnectId DrawingArea + -> [RItem] -- [StrokeBBox] + -> (Double,Double) + -> MainCoroutine () +eraserProcess cid pnum geometry connidmove connidup itms (x0,y0) = do + r <- nextevent + xst <- get + boxAction (f r xst) . getCanvasInfo cid $ xst + where + f :: (ViewMode a) => MyEvent -> HoodleState -> CanvasInfo a -> MainCoroutine () + f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact + (moveact xstate cvsInfo) upact + defact = eraserProcess cid pnum geometry connidup connidmove itms (x0,y0) + upact _ = disconnect [connidmove,connidup] >> invalidateAll + moveact xstate cvsInfo (_pcoord,(x,y)) = do + let line = ((x0,y0),(x,y)) + hittestbbox = hltHittedByLineRough line itms + (hittestitem,hitState) = + St.runState (hltItmsHittedByLineFrmSelected_StateT line hittestbbox) False + if hitState + then do + page <- getCurrentPageCvsId cid + let currhdl = unView . view hoodleModeState $ xstate + pgnum = view currentPageNum cvsInfo + (mcurrlayer, currpage) = getCurrentLayerOrSet page + currlayer = maybe (error "eraserProcess") id mcurrlayer + let (newitms,maybebbox1) = St.runState (eraseHitted hittestitem) Nothing + maybebbox = fmap (flip inflate 2.0) maybebbox1 + newlayerbbox <- liftIO . updateLayerBuf maybebbox + . set gitems newitms $ currlayer + let newpagebbox = adjustCurrentLayer newlayerbbox currpage + newhdlbbox = over gpages (IM.adjust (const newpagebbox) pgnum) currhdl + newhdlmodst = ViewAppendState newhdlbbox + commit . set hoodleModeState newhdlmodst + =<< (liftIO (updatePageAll newhdlmodst xstate)) + invalidateWithBuf cid + nitms <- rItmsInCurrLyr + eraserProcess cid pnum geometry connidup connidmove nitms (x,y) + else eraserProcess cid pnum geometry connidmove connidup itms (x,y) + diff --git a/src/Hoodle/Coroutine/EventConnect.hs b/src/Hoodle/Coroutine/EventConnect.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/EventConnect.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.EventConnect +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.EventConnect where + +import Graphics.UI.Gtk hiding (get,set,disconnect) +-- import qualified Control.Monad.State as St +import Control.Applicative +import Control.Monad.Trans +import Control.Category +import Control.Lens +import Control.Monad.State +-- +import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Queue +-- +import Hoodle.Type.Event +import Hoodle.Type.Canvas +import Hoodle.Type.HoodleState +import Hoodle.Device +import Hoodle.Type.Coroutine +-- +import Prelude hiding ((.), id) + +-- | +disconnect :: (WidgetClass w) => [ConnectId w] -> MainCoroutine () +disconnect is = modify (tempQueue %~ enqueue action) >> go + where + go = do r <- nextevent + case r of + EventDisconnected -> return () + _ -> go + action = Left . ActionOrder $ + \_ -> mapM_ signalDisconnect is >> return EventDisconnected +-- liftIO . signalDisconnect + +-- | +connectPenUp :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea) +connectPenUp cinfo = do + let cid = view canvasId cinfo + canvas = view drawArea cinfo + connPenUp canvas cid + +-- | +connectPenMove :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea) +connectPenMove cinfo = do + let cid = view canvasId cinfo + canvas = view drawArea cinfo + connPenMove canvas cid + +-- | + +connPenMove :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w) +connPenMove c cid = do + callbk <- view callBack <$> get + dev <- view deviceList <$> get + liftIO (c `on` motionNotifyEvent $ tryEvent $ do + (_,p) <- getPointer dev + liftIO (callbk (PenMove cid p))) + +-- | + +connPenUp :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w) +connPenUp c cid = do + callbk <- view callBack <$> get + dev <- view deviceList <$> get + liftIO (c `on` buttonReleaseEvent $ tryEvent $ do + (_,p) <- getPointer dev + liftIO (callbk (PenMove cid p))) diff --git a/src/Hoodle/Coroutine/File.hs b/src/Hoodle/Coroutine/File.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/File.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.File +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.File where + +-- from other packages +import Control.Category +import Control.Lens +import Control.Monad.State +import Data.ByteString.Char8 as B (pack) +import qualified Data.ByteString.Lazy as L +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk hiding (get,set) +import System.Directory +import System.FilePath +-- from hoodle-platform +import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Queue +import Data.Hoodle.Generic +import Data.Hoodle.Simple +import Data.Hoodle.Select +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Item +import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest +import Text.Hoodle.Builder +-- from this package +import Hoodle.Coroutine.Draw +import Hoodle.Coroutine.Commit +import Hoodle.Coroutine.Mode +import Hoodle.ModelAction.File +import Hoodle.ModelAction.Layer +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Select +import Hoodle.ModelAction.Window +import qualified Hoodle.Script.Coroutine as S +import Hoodle.Script.Hook +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.Event +import Hoodle.Type.HoodleState +-- +import Prelude hiding ((.),id) + +-- | +okMessageBox :: String -> MainCoroutine () +okMessageBox msg = modify (tempQueue %~ enqueue action) >> go + where + go = do r <- nextevent + case r of + GotOk -> return () + _ -> go + action = Left . ActionOrder $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal] + MessageQuestion ButtonsOk msg + _res <- dialogRun dialog + widgetDestroy dialog + return GotOk + +-- | +okCancelMessageBox :: String -> MainCoroutine Bool +okCancelMessageBox msg = modify (tempQueue %~ enqueue action) >> go + where + action = Left . ActionOrder $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal] + MessageQuestion ButtonsOkCancel msg + res <- dialogRun dialog + let b = case res of + ResponseOk -> True + _ -> False + widgetDestroy dialog + return (OkCancel b) + go = do r <- nextevent + case r of + OkCancel b -> return b + _ -> go + +-- | +fileChooser :: FileChooserAction -> MainCoroutine (Maybe FilePath) +fileChooser choosertyp = modify (tempQueue %~ enqueue action) >> go + where + go = do r <- nextevent + case r of + FileChosen b -> return b + _ -> go + action = Left . ActionOrder $ \_evhandler -> do + dialog <- fileChooserDialogNew Nothing Nothing choosertyp + [ ("OK", ResponseOk) + , ("Cancel", ResponseCancel) ] + cwd <- getCurrentDirectory + fileChooserSetCurrentFolder dialog cwd + res <- dialogRun dialog + mr <- case res of + ResponseDeleteEvent -> return Nothing + ResponseOk -> fileChooserGetFilename dialog + ResponseCancel -> return Nothing + _ -> putStrLn "??? in fileOpen" >> return Nothing + widgetDestroy dialog + return (FileChosen mr) + +-- | +askIfSave :: MainCoroutine () -> MainCoroutine () +askIfSave action = do + xstate <- get + if not (view isSaved xstate) + then do + b <- okCancelMessageBox "Current canvas is not saved yet. Will you proceed without save?" + case b of + True -> action + False -> return () + else action + +-- | +fileNew :: MainCoroutine () +fileNew = do + xstate <- get + xstate' <- liftIO $ getFileContent Nothing xstate + ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate') + xstate'' <- return $ over currentCanvasInfo (const ncvsinfo) xstate' + liftIO $ setTitleFromFileName xstate'' + commit xstate'' + invalidateAll + +-- | +fileSave :: MainCoroutine () +fileSave = do + xstate <- get + case view currFileName xstate of + Nothing -> fileSaveAs + Just filename -> do + -- this is rather temporary not to make mistake + if takeExtension filename == ".hdl" + then do + let hdl = (rHoodle2Hoodle . getHoodle) xstate + liftIO . L.writeFile filename . builder $ hdl + put . set isSaved True $ xstate + let ui = view gtkUIManager xstate + liftIO $ toggleSave ui False + S.afterSaveHook hdl + else fileExtensionInvalid (".hdl","save") >> fileSaveAs + + +-- | interleaving a monadic action between each pair of subsequent actions +sequence1_ :: (Monad m) => m () -> [m ()] -> m () +sequence1_ _ [] = return () +sequence1_ _ [a] = a +sequence1_ i (a:as) = a >> i >> sequence1_ i as + +-- | +renderjob :: Hoodle -> FilePath -> IO () +renderjob h ofp = do + let p = head (hoodle_pages h) + let Dim width height = page_dim p + withPDFSurface ofp width height $ \s -> renderWith s $ + (sequence1_ showPage . map renderPage . hoodle_pages) h + + +-- | +fileExport :: MainCoroutine () +fileExport = fileChooser FileChooserActionSave >>= maybe (return ()) action + where + action filename = + -- this is rather temporary not to make mistake + if takeExtension filename /= ".pdf" + then fileExtensionInvalid (".pdf","export") >> fileExport + else do + xstate <- get + let hdl = (rHoodle2Hoodle . getHoodle) xstate + liftIO (renderjob hdl filename) + + +-- | +fileLoad :: FilePath -> MainCoroutine () +fileLoad filename = do + xstate <- get + xstate' <- liftIO $ getFileContent (Just filename) xstate + ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate') + xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate' + put . set isSaved True + $ xstateNew + liftIO $ setTitleFromFileName xstateNew + clearUndoHistory + invalidateAll + + +-- | main coroutine for open a file +fileOpen :: MainCoroutine () +fileOpen = do + mfilename <- fileChooser FileChooserActionOpen + case mfilename of + Nothing -> return () + Just filename -> fileLoad filename + +-- | main coroutine for save as +fileSaveAs :: MainCoroutine () +fileSaveAs = do + xstate <- get + let hdl = (rHoodle2Hoodle . getHoodle) xstate + maybe (defSaveAsAction xstate hdl) (\f -> liftIO (f hdl)) + (hookSaveAsAction xstate) + where + hookSaveAsAction xstate = do + hset <- view hookSet xstate + saveAsHook hset + defSaveAsAction xstate hdl = + fileChooser FileChooserActionSave + >>= maybe (return ()) (action xstate hdl) + where action xst' hd filename = + if takeExtension filename /= ".hdl" + then fileExtensionInvalid (".hdl","save") + else do + let ntitle = B.pack . snd . splitFileName $ filename + (hdlmodst',hdl') = case view hoodleModeState xst' of + ViewAppendState hdlmap -> + if view gtitle hdlmap == "untitled" + then ( ViewAppendState . set gtitle ntitle + $ hdlmap + , (set title ntitle hd)) + else (ViewAppendState hdlmap,hd) + SelectState thdl -> + if view gselTitle thdl == "untitled" + then ( SelectState $ set gselTitle ntitle thdl + , set title ntitle hd) + else (SelectState thdl,hd) + xstateNew = set currFileName (Just filename) + . set hoodleModeState hdlmodst' $ xst' + liftIO . L.writeFile filename . builder $ hdl' + put . set isSaved True $ xstateNew + let ui = view gtkUIManager xstateNew + liftIO $ toggleSave ui False + liftIO $ setTitleFromFileName xstateNew + S.afterSaveHook hdl' + + +-- | main coroutine for open a file +fileReload :: MainCoroutine () +fileReload = do + xstate <- get + case view currFileName xstate of + Nothing -> return () + Just filename -> do + if not (view isSaved xstate) + then do + b <- okCancelMessageBox "Discard changes and reload the file?" + case b of + True -> fileLoad filename + False -> return () + else fileLoad filename + +-- | +fileExtensionInvalid :: (String,String) -> MainCoroutine () +fileExtensionInvalid (ext,a) = + okMessageBox $ "only " + ++ ext + ++ " extension is supported for " + ++ a + +-- | +fileAnnotatePDF :: MainCoroutine () +fileAnnotatePDF = + fileChooser FileChooserActionOpen >>= maybe (return ()) action + where + action filename = do + xstate <- get + mhdl <- liftIO $ makeNewHoodleWithPDF filename + flip (maybe (return ())) mhdl $ \hdl -> do + xstateNew <- return . set currFileName Nothing + =<< (liftIO $ constructNewHoodleStateFromHoodle hdl xstate) + commit xstateNew + liftIO $ setTitleFromFileName xstateNew + invalidateAll + + +-- | +fileLoadImage :: MainCoroutine () +fileLoadImage = do + fileChooser FileChooserActionOpen >>= maybe (return ()) action + where + action filename = do + xstate <- get + liftIO $ putStrLn filename + let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate + hdl = getHoodle xstate + (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl) + currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer + newitem <- (liftIO . cnstrctRItem . ItemImage) + (Image (B.pack filename) (100,100) (Dim 300 300)) + let otheritems = view gitems currlayer + let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) + modeChange ToSelectMode + nxstate <- get + let thdl = case view hoodleModeState nxstate of + SelectState thdl' -> thdl' + _ -> error "fileLoadImage" + nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate + put nxstate2 + invalidateAll + +-- | +askQuitProgram :: MainCoroutine () +askQuitProgram = do + b <- okCancelMessageBox "Current canvas is not saved yet. Will you close hoodle?" + case b of + True -> liftIO mainQuit + False -> return () + + diff --git a/src/Hoodle/Coroutine/Highlighter.hs b/src/Hoodle/Coroutine/Highlighter.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Highlighter.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Highlighter +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Highlighter where + +import Hoodle.Device +import Hoodle.Type.Coroutine +import Hoodle.Type.Canvas +import Hoodle.Coroutine.Pen + +import Control.Monad.Trans + +-- | + +highlighterStart :: CanvasId -> PointerCoord -> MainCoroutine () +highlighterStart cid pcoord = do + liftIO $ putStrLn "highlighter started" + penStart cid pcoord diff --git a/src/Hoodle/Coroutine/Layer.hs b/src/Hoodle/Coroutine/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Layer.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Layer +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Layer where + +import Control.Monad.State +import qualified Data.IntMap as M +import Control.Compose +import Control.Category +-- import Data.Label +import Control.Lens +import Data.IORef +import Graphics.UI.Gtk hiding (get,set) +-- +import Data.Hoodle.Generic +import Data.Hoodle.Zipper +import Graphics.Hoodle.Render.Type +-- +import Hoodle.Accessor +import Hoodle.Coroutine.Commit +import Hoodle.ModelAction.Layer +import Hoodle.ModelAction.Page +import Hoodle.Type.Alias +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.HoodleState +-- +import Prelude hiding ((.),id) + + +layerAction :: (HoodleModeState -> Int -> Page EditMode -> MainCoroutine HoodleModeState) + -> MainCoroutine HoodleState +layerAction action = do + xst <- get + selectBoxAction (fsingle xst) (fsingle xst) . view currentCanvasInfo $ xst + where + fsingle xstate cvsInfo = do + let epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst + cpn = view currentPageNum cvsInfo + hdlmodst = view hoodleModeState xstate + newhdlmodst <- either (action hdlmodst cpn) (action hdlmodst cpn . hPage2RPage) epage + return =<< (liftIO (updatePageAll newhdlmodst . set hoodleModeState newhdlmodst $ xstate)) + +-- | + +makeNewLayer :: MainCoroutine () +makeNewLayer = layerAction newlayeraction >>= commit + where newlayeraction hdlmodst cpn page = do + let (_,currpage) = getCurrentLayerOrSet page + Select (O (Just lyrzipper)) = view glayers currpage + -- emptylyr <- liftIO ( emptyRLayer) + let emptylyr = emptyRLayer + let nlyrzipper = appendGoLast lyrzipper emptylyr + npage = set glayers (Select (O (Just nlyrzipper))) currpage + return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst + + +gotoNextLayer :: MainCoroutine () +gotoNextLayer = layerAction nextlayeraction >>= put + where nextlayeraction hdlmodst cpn page = do + let (_,currpage) = getCurrentLayerOrSet page + Select (O (Just lyrzipper)) = view glayers currpage + let mlyrzipper = moveRight lyrzipper + + npage = maybe currpage (\x-> set glayers (Select (O (Just x))) currpage) mlyrzipper + case mlyrzipper of + Nothing -> liftIO $ putStrLn "Nothing" + Just _ -> liftIO $ putStrLn "Just" + return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst + +gotoPrevLayer :: MainCoroutine () +gotoPrevLayer = layerAction prevlayeraction >>= put + where prevlayeraction hdlmodst cpn page = do + let (_,currpage) = getCurrentLayerOrSet page + Select (O (Just lyrzipper)) = view glayers currpage + let mlyrzipper = moveLeft lyrzipper + npage = maybe currpage (\x -> set glayers (Select (O (Just x))) currpage) mlyrzipper + case mlyrzipper of + Nothing -> liftIO $ putStrLn "Nothing" + Just _ -> liftIO $ putStrLn "Just" + return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst + + +gotoLayerAt :: Int -> MainCoroutine () +gotoLayerAt n = layerAction gotoaction >>= put + where gotoaction hdlmodst cpn page = do + let (_,currpage) = getCurrentLayerOrSet page + Select (O (Just lyrzipper)) = view glayers currpage + let mlyrzipper = moveTo n lyrzipper + npage = maybe currpage (\x -> set glayers (Select (O (Just x))) currpage) mlyrzipper + return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst + + +deleteCurrentLayer :: MainCoroutine () +deleteCurrentLayer = layerAction deletelayeraction >>= commit + where deletelayeraction hdlmodst cpn page = do + let (mcurrlayer,currpage) = getCurrentLayerOrSet page + flip (maybe (return hdlmodst)) mcurrlayer $ + const $ do + let Select (O (Just lyrzipper)) = view glayers currpage + mlyrzipper = deleteCurrent lyrzipper + npage = maybe currpage + (\x -> set glayers (Select (O (Just x))) currpage) + mlyrzipper + return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst + +startGotoLayerAt :: MainCoroutine () +startGotoLayerAt = + selectBoxAction fsingle fsingle . view currentCanvasInfo =<< get + where + fsingle cvsInfo = do + xstate <- get + let hdlmodst = view hoodleModeState xstate + let epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst + page = either id (hPage2RPage) epage + (_,currpage) = getCurrentLayerOrSet page + Select (O (Just lyrzipper)) = view glayers currpage + cidx = currIndex lyrzipper + len = lengthSZ lyrzipper + lref <- liftIO $ newIORef cidx + dialog <- liftIO (layerChooseDialog lref cidx len) + res <- liftIO $ dialogRun dialog + case res of + ResponseDeleteEvent -> liftIO $ widgetDestroy dialog + ResponseOk -> do + liftIO $ widgetDestroy dialog + newnum <- liftIO (readIORef lref) + liftIO $ putStrLn (show (newnum)) + gotoLayerAt newnum + ResponseCancel -> liftIO $ widgetDestroy dialog + _ -> error "??? in fileOpen " + return () + diff --git a/src/Hoodle/Coroutine/Mode.hs b/src/Hoodle/Coroutine/Mode.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Mode.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Mode +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Mode where + +import Control.Applicative +import Control.Category +-- import Data.Label +import Control.Lens +import Control.Monad.Trans +import qualified Data.IntMap as M +import Graphics.UI.Gtk (adjustmentGetValue) +-- +import Data.Hoodle.BBox +import Data.Hoodle.Generic +import Data.Hoodle.Select +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type +-- from this package +import Hoodle.Accessor +import Hoodle.Coroutine.Scroll +import Hoodle.Coroutine.Draw +import Hoodle.Type.Alias +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.Event +import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement +import Hoodle.View.Coordinate +-- +import Prelude hiding ((.),id, mapM_, mapM) + +modeChange :: MyEvent -> MainCoroutine () +modeChange command = case command of + ToViewAppendMode -> updateXState select2edit >> invalidateAll + ToSelectMode -> updateXState edit2select >> invalidateAll + _ -> return () + where select2edit xst = + either (noaction xst) (whenselect xst) . hoodleModeStateEither . view hoodleModeState $ xst + edit2select xst = + either (whenedit xst) (noaction xst) . hoodleModeStateEither . view hoodleModeState $ xst + noaction :: HoodleState -> a -> MainCoroutine HoodleState + noaction xstate = const (return xstate) + whenselect :: HoodleState -> Hoodle SelectMode -> MainCoroutine HoodleState + whenselect xstate thdl = do + let pages = view gselAll thdl + mselect = view gselSelected thdl + npages <- maybe (return pages) + (\(spgn,spage) -> do + npage <- (liftIO.updatePageBuf.hPage2RPage) spage + return $ M.adjust (const npage) spgn pages ) + mselect + return . flip (set hoodleModeState) xstate + . ViewAppendState . GHoodle (view gselTitle thdl) $ npages + whenedit :: HoodleState -> Hoodle EditMode -> MainCoroutine HoodleState + whenedit xstate hdl = return . flip (set hoodleModeState) xstate + . SelectState + $ GSelect (view gtitle hdl) (view gpages hdl) Nothing + +-- | + +viewModeChange :: MyEvent -> MainCoroutine () +viewModeChange command = do + case command of + ToSinglePage -> updateXState cont2single >> invalidateAll + ToContSinglePage -> updateXState single2cont >> invalidateAll + _ -> return () + adjustScrollbarWithGeometryCurrent + where cont2single xst = + selectBoxAction (noaction xst) (whencont xst) . view currentCanvasInfo $ xst + single2cont xst = + selectBoxAction (whensing xst) (noaction xst) . view currentCanvasInfo $ xst + noaction :: HoodleState -> a -> MainCoroutine HoodleState + noaction xstate = const (return xstate) + ------------------------------------- + whencont xstate cinfo = do + geometry <- liftIO $ getGeometry4CurrCvs xstate + cdim <- liftIO $ return . canvasDim $ geometry + -- =<< getCanvasGeometry xstate + page <- getCurrentPageCurr + let zmode = view (viewInfo.zoomMode) cinfo + canvas = view drawArea cinfo + cpn = PageNum . view currentPageNum $ cinfo + + pdim = PageDimension (view gdimension page) + ViewPortBBox bbox = view (viewInfo.pageArrangement.viewPortBBox) cinfo + (x0,y0) = bbox_upperleft bbox + (xpos,ypos) = maybe (0,0) (unPageCoord.snd) $ desktop2Page geometry (DeskCoord (x0,y0)) + let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos) + let nvinfo = ViewInfo (view zoomMode (view viewInfo cinfo)) arr + ncinfo = CanvasInfo (view canvasId cinfo) + canvas + (view scrolledWindow cinfo) + nvinfo + (unPageNum cpn) + (view horizAdjustment cinfo) + (view vertAdjustment cinfo) + (view horizAdjConnId cinfo) + (view vertAdjConnId cinfo) + -- liftIO $ putStrLn " after " + -- liftIO $ printCanvasMode (getCurrentCanvasId xstate) (CanvasSinglePage ncinfo) + return $ set currentCanvasInfo (CanvasSinglePage ncinfo) xstate + ------------------------------------- + whensing xstate cinfo = do + cdim <- liftIO $ return . canvasDim =<< getGeometry4CurrCvs xstate + let zmode = view (viewInfo.zoomMode) cinfo + canvas = view drawArea cinfo + cpn = PageNum . view currentPageNum $ cinfo + (hadj,vadj) = view adjustments cinfo + (xpos,ypos) <- liftIO $ (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj + let arr = makeContinuousArrangement zmode cdim (getHoodle xstate) + (cpn, PageCoord (xpos,ypos)) + geometry <- liftIO $ makeCanvasGeometry cpn arr canvas + let DeskCoord (nxpos,nypos) = page2Desktop geometry (cpn,PageCoord (xpos,ypos)) + let vinfo = view viewInfo cinfo + nvinfo = ViewInfo (view zoomMode vinfo) arr + ncinfotemp = CanvasInfo (view canvasId cinfo) + (view drawArea cinfo) + (view scrolledWindow cinfo) + nvinfo + (view currentPageNum cinfo) + hadj + vadj + (view horizAdjConnId cinfo) + (view vertAdjConnId cinfo) + ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos)) + ncinfo = over currentPageNum (const (unPageNum ncpn)) ncinfotemp + return . over currentCanvasInfo (const (CanvasContPage ncinfo)) $ xstate + + + {- + let hdl = getHoodle xstate + cinfo' <- liftIO $ updateCvsInfoFrmHoodle hdl cinfo + return . modifyCurrentCanvasInfo (const cinfo') $ xstate + -} diff --git a/src/Hoodle/Coroutine/Page.hs b/src/Hoodle/Coroutine/Page.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Page.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Page +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Page where + +import Control.Category +import Control.Lens +import Control.Monad +import Control.Monad.State +import qualified Data.IntMap as M +-- from hoodle-platform +import Data.Hoodle.Generic +import Data.Hoodle.Select +-- 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 +-- +import Prelude hiding ((.), id) + +-- | change page of current canvas using a modify function + +changePage :: (Int -> Int) -> MainCoroutine () +changePage modifyfn = updateXState changePageAction + >> adjustScrollbarWithGeometryCurrent + >> invalidateCurrent + where changePageAction xst = selectBoxAction (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 + (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState 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 + (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState 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 :: Int -> HoodleModeState + -> (Bool,Int,Page EditMode,HoodleModeState) +changePageInHoodleModeState 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 npage = 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 + -> MainCoroutine () +canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode + = updateXState zoomUpdateAction + >> adjustScrollbarWithGeometryCvsId cid + >> renderfunc + where zoomUpdateAction xst = + selectBoxAction (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 = 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 = canvasZoomUpdateGenRenderCvsId invalidateAll + +-- | + +canvasZoomUpdateBufAll :: MainCoroutine () +canvasZoomUpdateBufAll = do + klst <- liftM (M.keys . getCanvasInfoMap) get + mapM_ updatefunc klst + where + updatefunc cid + = canvasZoomUpdateGenRenderCvsId (invalidateWithBuf cid) cid 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 + boxAction fsingle . view currentCanvasInfo =<< get + where + fsingle :: (ViewMode a) => 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 = boxAction (fsimple xst) . view currentCanvasInfo $ xst + fsimple :: (ViewMode a) => HoodleState -> CanvasInfo a + -> MainCoroutine HoodleState + fsimple xstate cinfo = do + case view hoodleModeState xstate of + ViewAppendState hdl -> do + hdl' <- liftIO $ addNewPageInHoodle 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 = boxAction (fsimple xst) . view currentCanvasInfo $ xst + fsimple :: (ViewMode a) => 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 + putStrLn "deletePageInHoodle is called" + 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 + + + diff --git a/src/Hoodle/Coroutine/Pen.hs b/src/Hoodle/Coroutine/Pen.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Pen.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE Rank2Types, GADTs, ScopedTypeVariables, TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Pen +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Pen where + +-- from other packages +import Control.Category +import Control.Lens +import Control.Monad +import Control.Monad.State +-- import Control.Monad.Trans +import Data.Sequence hiding (filter) +import qualified Data.Map as M +import Data.Maybe +import Graphics.UI.Gtk hiding (get,set,disconnect) +-- from hoodle-platform +import Data.Hoodle.Predefined +import Data.Hoodle.BBox +-- from this package +import Hoodle.Accessor +import Hoodle.Device +import Hoodle.Coroutine.Commit +import Hoodle.Coroutine.Draw +import Hoodle.Coroutine.EventConnect +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Pen +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.Enum +import Hoodle.Type.Event +import Hoodle.Type.PageArrangement +import Hoodle.Type.HoodleState +import Hoodle.Util +import Hoodle.View.Coordinate +import Hoodle.View.Draw +-- +import Prelude hiding ((.), id) + + +-- | page switch if pen click a page different than the current page +penPageSwitch :: -- (ViewMode a) => + -- CanvasInfo a -> + PageNum -> MainCoroutine CanvasInfoBox -- (CanvasInfo a) +penPageSwitch {- cinfo -} pgn = do + xstate <- get + let cibox = view currentCanvasInfo xstate + -- ncinfo = set currentPageNum (unPageNum pgn) cinfo + ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum pgn)) cibox + put (set currentCanvasInfo ncibox xstate) + return ncibox + +{- + mfunc = const (return . CanvasInfoBox $ ncinfo) + (xst,cinfo') <- get >>= switchact + put xst + return cinfo' + where switchact xst = do + return . (,ncinfo) =<< modifyCurrCvsInfoM mfunc xst +-} + +-- | Common Pen Work starting point +commonPenStart :: (forall a. ViewMode a => CanvasInfo a -> PageNum -> CanvasGeometry + -> (ConnectId DrawingArea, ConnectId DrawingArea) + -> (Double,Double) -> MainCoroutine () ) + -> CanvasId -> PointerCoord + -> MainCoroutine () +commonPenStart action cid pcoord = do + oxstate <- get + let currcid = getCurrentCanvasId oxstate + when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll) + nxstate <- get + boxAction f . getCanvasInfo cid $ nxstate + where f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine () + f cvsInfo = do + let cpn = PageNum . view currentPageNum $ cvsInfo + arr = view (viewInfo.pageArrangement) cvsInfo + canvas = view drawArea cvsInfo + geometry <- liftIO $ makeCanvasGeometry cpn arr canvas + let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord + maybeFlip pagecoord (return ()) + $ \(pgn,PageCoord (x,y)) -> do + nCvsInfo <- if (cpn /= pgn) + then do penPageSwitch pgn + -- temporary dirty fix + return (set currentPageNum (unPageNum pgn) cvsInfo ) + else return cvsInfo + connidup <- connectPenUp nCvsInfo + connidmove <- connectPenMove nCvsInfo + action nCvsInfo pgn geometry (connidup,connidmove) (x,y) + + +-- | enter pen drawing mode +penStart :: CanvasId -> PointerCoord -> MainCoroutine () +penStart cid pcoord = commonPenStart penAction cid pcoord + where penAction :: forall b. (ViewMode b) => CanvasInfo b -> PageNum -> CanvasGeometry -> (ConnectId DrawingArea, ConnectId DrawingArea) -> (Double,Double) -> MainCoroutine () + penAction _cinfo pnum geometry (cidmove,cidup) (x,y) = do + xstate <- get + let PointerCoord _ _ _ z = pcoord + let currhdl = unView . view hoodleModeState $ xstate + pinfo = view penInfo xstate + pdraw <-penProcess cid pnum geometry cidmove cidup (empty |> (x,y,z)) ((x,y),z) + (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw + commit . set hoodleModeState (ViewAppendState newhdl) + =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate)) + let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord + nbbox = xformBBox f bbox + invalidateAllInBBox (Just (inflate nbbox 2.0)) + +-- | main pen coordinate adding process +-- | now being changed +penProcess :: CanvasId -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea -> ConnectId DrawingArea + -> Seq (Double,Double,Double) -> ((Double,Double),Double) + -> MainCoroutine (Seq (Double,Double,Double)) +penProcess cid pnum geometry connidmove connidup pdraw ((x0,y0),z0) = do + r <- nextevent + xst <- get + boxAction (fsingle r xst) . getCanvasInfo cid $ xst + where + fsingle :: forall b. (ViewMode b) => + MyEvent -> HoodleState -> CanvasInfo b + -> MainCoroutine (Seq (Double,Double,Double)) + fsingle r xstate cvsInfo = + penMoveAndUpOnly r pnum geometry + (penProcess cid pnum geometry connidmove connidup pdraw ((x0,y0),z0)) + (\(pcoord,(x,y)) -> do + let PointerCoord _ _ _ z = pcoord + let canvas = view drawArea cvsInfo + ptype = view (penInfo.penType) xstate + pcolor = view (penInfo.currentTool.penColor) xstate + pwidth = view (penInfo.currentTool.penWidth) xstate + (pcr,pcg,pcb,pca)= fromJust (M.lookup pcolor penColorRGBAmap) + opacity = case ptype of + HighlighterWork -> predefined_highlighter_opacity + _ -> 1.0 + pcolRGBA = (pcr,pcg,pcb,pca*opacity) + let pressureType = case view (penInfo.variableWidthPen) xstate of + True -> Pressure + False -> NoPressure + liftIO $ drawCurvebitGen pressureType canvas geometry + pwidth pcolRGBA pnum ((x0,y0),z0) ((x,y),z) + penProcess cid pnum geometry connidmove connidup (pdraw |> (x,y,z)) ((x,y),z) ) + (\_ -> disconnect [connidmove,connidup] >> return pdraw ) + +-- | +skipIfNotInSamePage :: Monad m => + PageNum -> CanvasGeometry -> PointerCoord + -> m a + -> ((PointerCoord,(Double,Double)) -> m a) + -> m a +skipIfNotInSamePage pgn geometry pcoord skipaction ordaction = + switchActionEnteringDiffPage pgn geometry pcoord + skipaction (\_ _ -> skipaction ) (\_ (_,PageCoord xy)->ordaction (pcoord,xy)) + +-- | +switchActionEnteringDiffPage :: Monad m => + PageNum -> CanvasGeometry -> PointerCoord + -> m a + -> (PageNum -> (PageNum,PageCoordinate) -> m a) + -> (PageNum -> (PageNum,PageCoordinate) -> m a) + -> m a +switchActionEnteringDiffPage pgn geometry pcoord skipaction chgaction ordaction = do + let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord + maybeFlip pagecoord skipaction + $ \(cpn, pxy) -> if pgn == cpn + then ordaction pgn (cpn,pxy) + else chgaction pgn (cpn,pxy) + + +-- | in page action +penMoveAndUpOnly :: Monad m => MyEvent + -> PageNum + -> CanvasGeometry + -> m a + -> ((PointerCoord,(Double,Double)) -> m a) + -> (PointerCoord -> m a) + -> m a +penMoveAndUpOnly r pgn geometry defact moveaction upaction = + case r of + PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction + PenUp _ pcoord -> upaction pcoord + _ -> defact + +-- | +penMoveAndUpInterPage :: Monad m => MyEvent + -> PageNum + -> CanvasGeometry + -> m a + -> (PageNum -> (PageNum,PageCoordinate) -> m a) + -> (PointerCoord -> m a) + -> m a +penMoveAndUpInterPage r pgn geometry defact moveaction upaction = + case r of + PenMove _ pcoord -> + switchActionEnteringDiffPage pgn geometry pcoord defact moveaction moveaction + PenUp _ pcoord -> upaction pcoord + _ -> defact + + + + diff --git a/src/Hoodle/Coroutine/Scroll.hs b/src/Hoodle/Coroutine/Scroll.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Scroll.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Scroll +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Scroll where + +import Control.Category +import Control.Lens +import Control.Monad +import Control.Monad.State +-- from hoodle-platform +import Data.Hoodle.BBox +-- from this package +import Hoodle.Type.Event +import Hoodle.Type.Coroutine +import Hoodle.Type.Canvas +import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement +import qualified Hoodle.ModelAction.Adjustment as A +import Hoodle.Coroutine.Draw +import Hoodle.Accessor +import Hoodle.View.Coordinate +-- +import Prelude hiding ((.), id) + +-- | +adjustScrollbarWithGeometryCvsId :: CanvasId -> MainCoroutine () +adjustScrollbarWithGeometryCvsId cid = do + xstate <- get + let cinfobox = getCanvasInfo cid xstate + geometry <- liftIO (getCanvasGeometryCvsId cid xstate) + let (hadj,vadj) = unboxGet adjustments cinfobox + connidh = unboxGet horizAdjConnId cinfobox + connidv = unboxGet vertAdjConnId cinfobox + liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv)) + + +-- | +adjustScrollbarWithGeometryCurrent :: MainCoroutine () +adjustScrollbarWithGeometryCurrent = do + xstate <- get + geometry <- liftIO . getGeometry4CurrCvs $ xstate + let cinfobox = view currentCanvasInfo xstate + let (hadj,vadj) = unboxGet adjustments cinfobox + connidh = unboxGet horizAdjConnId cinfobox + connidv = unboxGet vertAdjConnId cinfobox + liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv)) + +-- | +hscrollBarMoved :: CanvasId -> Double -> MainCoroutine () +hscrollBarMoved cid v = + changeCurrentCanvasId cid + >> updateXState (return . hscrollmoveAction) + >> invalidate cid + where hscrollmoveAction = over currentCanvasInfo (selectBox fsimple fsimple) + fsimple cinfo = + let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cinfo + in over (viewInfo.pageArrangement.viewPortBBox) (apply (moveBBoxULCornerTo (v,snd vm_orig))) $ cinfo + + +-- | +vscrollBarMoved :: CanvasId -> Double -> MainCoroutine () +vscrollBarMoved cid v = + chkCvsIdNInvalidate cid + >> updateXState (return . vscrollmoveAction) + >> invalidate cid + where vscrollmoveAction = over currentCanvasInfo (selectBox fsimple fsimple) + fsimple cinfo = + let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cinfo + in over (viewInfo.pageArrangement.viewPortBBox) (apply (moveBBoxULCornerTo (fst vm_orig,v))) $ cinfo + +-- | +vscrollStart :: CanvasId -> MainCoroutine () +vscrollStart cid = do + chkCvsIdNInvalidate cid + vscrollMove cid + + +-- | +vscrollMove :: CanvasId -> MainCoroutine () +vscrollMove cid = do + ev <- nextevent + xst <- get + geometry <- liftIO (getCanvasGeometryCvsId cid xst) + case ev of + VScrollBarMoved cid' v -> do + when (cid /= cid') $ error "something wrong in vscrollMove" + updateXState $ return . over currentCanvasInfo + (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) + invalidateWithBuf cid + vscrollMove cid + VScrollBarEnd cid' v -> do + when (cid /= cid') $ error "something wrong in vscrollMove" + updateXState $ return. over currentCanvasInfo + (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) + invalidate cid' + return () + VScrollBarStart cid' _v -> vscrollStart cid' + _ -> return () + where scrollmovecanvas v cvsInfo = + let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo + in over (viewInfo.pageArrangement.viewPortBBox) + (apply (moveBBoxULCornerTo (fst vm_orig,v))) cvsInfo + + scrollmovecanvasCont geometry v cvsInfo = + let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo + cpn = PageNum . view currentPageNum $ cvsInfo + ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (0,v)) + in over currentPageNum (const (unPageNum ncpn)) + . over (viewInfo.pageArrangement.viewPortBBox) + (apply (moveBBoxULCornerTo (fst vm_orig,v))) $ cvsInfo + + + + + + + + diff --git a/src/Hoodle/Coroutine/Select.hs b/src/Hoodle/Coroutine/Select.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Select.hs @@ -0,0 +1,538 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Select +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +-- selection-related coroutines +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Select where + +-- from other package +import Control.Category +import Control.Lens +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State +import Data.Monoid +import qualified Data.IntMap as M +import Data.Sequence (Seq,(|>)) +import qualified Data.Sequence as Sq (empty) +import Data.Time.Clock +import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo.Matrix as Mat +import Graphics.UI.Gtk hiding (get,set,disconnect) +-- from hoodle-platform +import Data.Hoodle.Select +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Generic +import Data.Hoodle.BBox +import Graphics.Hoodle.Render.Generic +import Graphics.Hoodle.Render.Util +import Graphics.Hoodle.Render.Util.HitTest +import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest +-- from this package +import Hoodle.Accessor +import Hoodle.Device +import Hoodle.Coroutine.Commit +import Hoodle.Coroutine.Draw +import Hoodle.Coroutine.EventConnect +import Hoodle.Coroutine.Mode +import Hoodle.Coroutine.Pen +import Hoodle.ModelAction.Layer +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Select +import Hoodle.Type.Alias +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.Enum +import Hoodle.Type.Event +import Hoodle.Type.PageArrangement +import Hoodle.Type.HoodleState +import Hoodle.View.Coordinate +import Hoodle.View.Draw +-- +import Prelude hiding ((.), id) + +-- | +createTempSelectRender :: PageNum -> CanvasGeometry -> Page EditMode + -> a + -> MainCoroutine (TempSelectRender a) +createTempSelectRender pnum geometry page x = do + let Dim cw ch = unCanvasDimension . canvasDim $ geometry + xformfunc = cairoXform4PageCoordinate geometry pnum + renderfunc = do + xformfunc + cairoRenderOption (InBBoxOption Nothing) (InBBox page) + return () + tempsurface <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch) + let tempselection = TempSelectRender tempsurface (cw,ch) x + liftIO $ updateTempSelection tempselection renderfunc True + return tempselection + + +-- | For Selection mode from pen mode with 2nd pen button +dealWithOneTimeSelectMode :: MainCoroutine () -- ^ main action + -> MainCoroutine () -- ^ terminating action + -> MainCoroutine () +dealWithOneTimeSelectMode action terminator = do + xstate <- get + case view isOneTimeSelectMode xstate of + NoOneTimeSelectMode -> action + YesBeforeSelect -> + action >> updateXState (return . set isOneTimeSelectMode YesAfterSelect) + YesAfterSelect -> do + terminator + updateXState (return . set isOneTimeSelectMode NoOneTimeSelectMode) + modeChange ToViewAppendMode + +-- | main mouse pointer click entrance in rectangular selection mode. +-- choose either starting new rectangular selection or move previously +-- selected selection. +selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine () +selectRectStart cid = commonPenStart rectaction cid + where rectaction cinfo pnum geometry (cidup,cidmove) (x,y) = do + itms <- rItmsInCurrLyr + ctime <- liftIO $ getCurrentTime + let newSelectAction page = + dealWithOneTimeSelectMode + (do tsel <- createTempSelectRender pnum geometry page [] + newSelectRectangle cid pnum geometry cidmove cidup itms + (x,y) ((x,y),ctime) tsel + surfaceFinish (tempSurface tsel)) + (disconnect [cidmove,cidup]) + let + action (Right tpage) | hitInHandle tpage (x,y) = + case getULBBoxFromSelected tpage of + Middle bbox -> + maybe (return ()) + (\handle -> startResizeSelect + handle cid pnum geometry cidmove cidup + bbox ((x,y),ctime) tpage) + (checkIfHandleGrasped bbox (x,y)) + _ -> return () + action (Right tpage) | hitInSelection tpage (x,y) = do + startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage + action (Right tpage) | otherwise = newSelectAction (hPage2RPage tpage) + action (Left page) = newSelectAction page + xstate <- get + let hdlmodst = view hoodleModeState xstate + let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + action epage + +-- | +newSelectRectangle :: CanvasId + -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea -> ConnectId DrawingArea + -> [RItem] + -> (Double,Double) + -> ((Double,Double),UTCTime) + -> TempSelection + -> MainCoroutine () +newSelectRectangle cid pnum geometry connidmove connidup itms orig + (prev,otime) tempselection = do + r <- nextevent + xst <- get + boxAction (fsingle r xst) . getCanvasInfo cid $ xst + where + fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact + (moveact xstate cinfo) (upact xstate cinfo) + defact = newSelectRectangle cid pnum geometry connidmove connidup itms orig + (prev,otime) tempselection + moveact _xstate _cinfo (_pcoord,(x,y)) = do + let bbox = BBox orig (x,y) + hittestbbox = hltEmbeddedByBBox bbox itms + hitteditms = takeHitted hittestbbox + page <- getCurrentPageCvsId cid + let (fitms,sitms) = separateFS $ getDiffBBox (tempSelected tempselection) hitteditms + (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) + when ((not.null) fitms || (not.null) sitms) $ do + let xformfunc = cairoXform4PageCoordinate geometry pnum + ulbbox = unUnion . mconcat . fmap (Union .Middle . flip inflate 5 . getBBox) $ fitms + renderfunc = do + xformfunc + case ulbbox of + Top -> do + cairoRenderOption (InBBoxOption Nothing) (InBBox page) + mapM_ renderSelectedItem hitteditms + Middle sbbox -> do + let redrawee = filter (do2BBoxIntersect sbbox.getBBox) hitteditms + cairoRenderOption (InBBoxOption (Just sbbox)) (InBBox page) + clipBBox (Just sbbox) + mapM_ renderSelectedItem redrawee + Bottom -> return () + mapM_ renderSelectedItem sitms + liftIO $ updateTempSelection tempselection renderfunc False + when willUpdate $ + invalidateTemp cid (tempSurface tempselection) + (renderBoxSelection bbox) + newSelectRectangle cid pnum geometry connidmove connidup itms orig + (ncoord,ntime) + tempselection { tempSelectInfo = hitteditms } + upact xstate cinfo pcoord = do + let (_,(x,y)) = runIdentity $ + skipIfNotInSamePage pnum geometry pcoord + (return (pcoord,prev)) return + epage = getCurrentPageEitherFromHoodleModeState cinfo (view hoodleModeState xstate) + cpn = view currentPageNum cinfo + bbox = BBox orig (x,y) + hittestbbox = hltEmbeddedByBBox bbox itms + selectitms = fmapAL unNotHitted id hittestbbox + SelectState thdl = view hoodleModeState xstate + newpage = case epage of + Left pagebbox -> makePageSelectMode pagebbox selectitms + Right tpage -> + let currlayer = view (glayers.selectedLayer) tpage + newlayer = set gitems (TEitherAlterHitted (Right selectitms)) currlayer + npage = set (glayers.selectedLayer) newlayer tpage + in npage + newthdl = set gselSelected (Just (cpn,newpage)) thdl + ui = view gtkUIManager xstate + liftIO $ toggleCutCopyDelete ui (isAnyHitted selectitms) + put . set hoodleModeState (SelectState newthdl) + =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) + disconnect [connidmove, connidup] + invalidateAll + + +-- | prepare for moving selection +startMoveSelect :: CanvasId + -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea + -> ConnectId DrawingArea + -> ((Double,Double),UTCTime) + -> Page SelectMode + -> MainCoroutine () +startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage = do + itmimage <- liftIO $ mkItmsNImg geometry tpage + tsel <- createTempSelectRender pnum geometry + (hPage2RPage tpage) + itmimage + moveSelect cid pnum geometry cidmove cidup (x,y) ((x,y),ctime) tsel + surfaceFinish (tempSurface tsel) + surfaceFinish (imageSurface itmimage) + +-- | +moveSelect :: CanvasId + -> PageNum -- ^ starting pagenum + -> CanvasGeometry + -> ConnectId DrawingArea + -> ConnectId DrawingArea + -> (Double,Double) + -> ((Double,Double),UTCTime) + -> TempSelectRender ItmsNImg + -> MainCoroutine () +moveSelect cid pnum geometry connidmove connidup orig@(x0,y0) + (prev,otime) tempselection = do + xst <- get + r <- nextevent + boxAction (fsingle r xst) . getCanvasInfo cid $ xst + where + fsingle r xstate cinfo = + penMoveAndUpInterPage r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) + defact = moveSelect cid pnum geometry connidmove connidup orig (prev,otime) + tempselection + moveact _xstate _cinfo oldpgn pcpair@(newpgn,PageCoord (px,py)) = do + let (x,y) + | oldpgn == newpgn = (px,py) + | otherwise = + let DeskCoord (xo,yo) = page2Desktop geometry (oldpgn,PageCoord (0,0)) + DeskCoord (xn,yn) = page2Desktop geometry pcpair + in (xn-xo,yn-yo) + + (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) + when willUpdate $ do + let sfunc = offsetFunc (x-x0,y-y0) + xform = unCvsCoord . desktop2Canvas geometry + . page2Desktop geometry . (,) pnum . PageCoord + (c1,c2) = xform (sfunc (0,0)) + (a1',a2') = xform (sfunc (1,0)) + (a1,a2) = (a1'-c1,a2'-c2) + (b1',b2') = xform (sfunc (0,1)) + (b1,b2) = (b1'-c1,b2'-c2) + xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 + invalidateTempBasePage cid (tempSurface tempselection) pnum + (drawTempSelectImage geometry tempselection xformmat) + moveSelect cid pnum geometry connidmove connidup orig (ncoord,ntime) + tempselection + upact :: (ViewMode a) => HoodleState -> CanvasInfo a -> PointerCoord -> MainCoroutine () + upact xst cinfo pcoord = + switchActionEnteringDiffPage pnum geometry pcoord (return ()) + (chgaction xst cinfo) + (ordaction xst cinfo) + chgaction :: (ViewMode a) => HoodleState -> CanvasInfo a -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () + chgaction xstate cinfo oldpgn (newpgn,PageCoord (x,y)) = do + let hdlmodst@(SelectState thdl) = view hoodleModeState xstate + epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + (xstate1,nthdl1,selecteditms) <- + case epage of + Right oldtpage -> do + let itms = getSelectedItms oldtpage + let oldtpage' = deleteSelected oldtpage + nthdl <- liftIO $ updateTempHoodleSelectIO thdl oldtpage' (unPageNum oldpgn) + xst <- return . set hoodleModeState (SelectState nthdl) + =<< (liftIO (updatePageAll (SelectState nthdl) xstate)) + return (xst,nthdl,itms) + Left _ -> error "this is impossible, in moveSelect" + let maction = do + page <- M.lookup (unPageNum newpgn) (view gselAll nthdl1) + let (mcurrlayer,npage) = getCurrentLayerOrSet page + currlayer <- mcurrlayer + let olditms = view gitems currlayer + let newitms = map (changeItemBy (offsetFunc (x-x0,y-y0))) selecteditms + alist = olditms :- Hitted newitms :- Empty + ntpage = makePageSelectMode npage alist + coroutineaction = do + nthdl2 <- liftIO $ updateTempHoodleSelectIO nthdl1 ntpage (unPageNum newpgn) + let -- ncinfo = set currentPageNum (unPageNum newpgn) $ cinfo + cibox = view currentCanvasInfo xstate1 + ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum newpgn)) cibox + cmap = getCanvasInfoMap xstate1 + -- cmap' = M.adjust (const (CanvasInfoBox ncinfo)) cid cmap + cmap' = M.adjust (const ncibox) cid cmap + xst = maybe xstate1 id $ setCanvasInfoMap cmap' xstate1 + return . set hoodleModeState (SelectState nthdl2) + =<< (liftIO (updatePageAll (SelectState nthdl2) xst)) + return coroutineaction + xstate2 <- maybe (return xstate1) id maction + commit xstate2 + disconnect [connidmove, connidup] + invalidateAll + ---- + ordaction xstate cinfo _pgn (_cpn,PageCoord (x,y)) = do + let offset = (x-x0,y-y0) + hdlmodst@(SelectState thdl) = view hoodleModeState xstate + epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + pagenum = view currentPageNum cinfo + case epage of + Right tpage -> do + let newtpage = changeSelectionByOffset offset tpage + newthdl <- liftIO $ updateTempHoodleSelectIO thdl newtpage pagenum + commit . set hoodleModeState (SelectState newthdl) + =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) + Left _ -> error "this is impossible, in moveSelect" + disconnect [connidmove, connidup] + invalidateAll + + +-- | prepare for resizing selection +startResizeSelect :: Handle + -> CanvasId + -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea + -> ConnectId DrawingArea + -> BBox + -> ((Double,Double),UTCTime) + -> Page SelectMode + -> MainCoroutine () +startResizeSelect handle cid pnum geometry cidmove cidup bbox + ((x,y),ctime) tpage = do + itmimage <- liftIO $ mkItmsNImg geometry tpage + tsel <- createTempSelectRender pnum geometry + (hPage2RPage tpage) + itmimage + resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel + surfaceFinish (tempSurface tsel) + surfaceFinish (imageSurface itmimage) + + +-- | +resizeSelect :: Handle + -> CanvasId + -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea + -> ConnectId DrawingArea + -> BBox + -> ((Double,Double),UTCTime) + -> TempSelectRender ItmsNImg + -> MainCoroutine () +resizeSelect handle cid pnum geometry connidmove connidup origbbox + (prev,otime) tempselection = do + xst <- get + r <- nextevent + boxAction (fsingle r xst) . getCanvasInfo cid $ xst + where + fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) + defact = resizeSelect handle cid pnum geometry connidmove connidup + origbbox (prev,otime) tempselection + moveact _xstate _cinfo (_pcoord,(x,y)) = do + (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) + when willUpdate $ do + let newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) + sfunc = scaleFromToBBox origbbox newbbox + xform = unCvsCoord . desktop2Canvas geometry + . page2Desktop geometry . (,) pnum . PageCoord + (c1,c2) = xform (sfunc (0,0)) + (a1',a2') = xform (sfunc (1,0)) + (a1,a2) = (a1'-c1,a2'-c2) + (b1',b2') = xform (sfunc (0,1)) + (b1,b2) = (b1'-c1,b2'-c2) + xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 + invalidateTemp cid (tempSurface tempselection) + (drawTempSelectImage geometry tempselection + xformmat) + resizeSelect handle cid pnum geometry connidmove connidup + origbbox (ncoord,ntime) tempselection + upact xstate cinfo pcoord = do + let (_,(x,y)) = runIdentity $ + skipIfNotInSamePage pnum geometry pcoord + (return (pcoord,prev)) return + newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) + hdlmodst@(SelectState thdl) = view hoodleModeState xstate + epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + pagenum = view currentPageNum cinfo + case epage of + Right tpage -> do + let sfunc = scaleFromToBBox origbbox newbbox + let newtpage = changeSelectionBy sfunc tpage + newthdl <- liftIO $ updateTempHoodleSelectIO thdl newtpage pagenum + commit . set hoodleModeState (SelectState newthdl) + =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) + Left _ -> error "this is impossible, in resizeSelect" + disconnect [connidmove, connidup] + invalidateAll + return () + + +-- | +selectPenColorChanged :: PenColor -> MainCoroutine () +selectPenColorChanged pcolor = do + xstate <- get + let SelectState thdl = view hoodleModeState xstate + Just (n,tpage) = view gselSelected thdl + slayer = view (glayers.selectedLayer) tpage + case unTEitherAlterHitted . view gitems $ slayer of + Left _ -> return () + Right alist -> do + let alist' = fmapAL id + (Hitted . map (changeItemStrokeColor pcolor) . unHitted) alist + newlayer = Right alist' + newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage + newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n + commit =<< liftIO (updatePageAll (SelectState newthdl) + . set hoodleModeState (SelectState newthdl) $ xstate ) + invalidateAll + +-- | +selectPenWidthChanged :: Double -> MainCoroutine () +selectPenWidthChanged pwidth = do + xstate <- get + let SelectState thdl = view hoodleModeState xstate + Just (n,tpage) = view gselSelected thdl + slayer = view (glayers.selectedLayer) tpage + case unTEitherAlterHitted . view gitems $ slayer of + Left _ -> return () + Right alist -> do + let alist' = fmapAL id + (Hitted . map (changeItemStrokeWidth pwidth) . unHitted) alist + newlayer = Right alist' + newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage + newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n + commit =<< liftIO (updatePageAll (SelectState newthdl) + . set hoodleModeState (SelectState newthdl) $ xstate ) + invalidateAll + +-- | main mouse pointer click entrance in lasso selection mode. +-- choose either starting new rectangular selection or move previously +-- selected selection. +selectLassoStart :: CanvasId -> PointerCoord -> MainCoroutine () +selectLassoStart cid = commonPenStart lassoAction cid + where lassoAction cinfo pnum geometry (cidup,cidmove) (x,y) = do + itms <- rItmsInCurrLyr + ctime <- liftIO $ getCurrentTime + let newSelectAction page = + dealWithOneTimeSelectMode + (do tsel <- createTempSelectRender pnum geometry page [] + newSelectLasso cinfo pnum geometry cidmove cidup itms + (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel + surfaceFinish (tempSurface tsel)) + (disconnect [cidmove, cidup] ) + let action (Right tpage) | hitInSelection tpage (x,y) = + startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage + action (Right tpage) | hitInHandle tpage (x,y) = + case getULBBoxFromSelected tpage of + Middle bbox -> + maybe (return ()) + (\handle -> startResizeSelect + handle cid pnum geometry cidmove cidup + bbox ((x,y),ctime) tpage) + (checkIfHandleGrasped bbox (x,y)) + _ -> return () + action (Right tpage) | otherwise = (newSelectAction . hPage2RPage) tpage + action (Left page) = newSelectAction page + xstate <- get + let hdlmodst = view hoodleModeState xstate + let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + action epage + +-- | +newSelectLasso :: (ViewMode a) => CanvasInfo a + -> PageNum + -> CanvasGeometry + -> ConnectId DrawingArea -> ConnectId DrawingArea + -> [RItem] + -> (Double,Double) + -> ((Double,Double),UTCTime) + -> Seq (Double,Double) + -> TempSelection + -> MainCoroutine () +newSelectLasso cvsInfo pnum geometry cidmove cidup itms orig (prev,otime) lasso tsel = do + r <- nextevent + fsingle r cvsInfo + where + fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact + (moveact cinfo) (upact cinfo) + defact = newSelectLasso cvsInfo pnum geometry cidmove cidup itms orig + (prev,otime) lasso tsel + moveact cinfo (_pcoord,(x,y)) = do + let nlasso = lasso |> (x,y) + (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) + when willUpdate $ do + invalidateTemp (view canvasId cinfo) (tempSurface tsel) (renderLasso nlasso) + newSelectLasso cinfo pnum geometry cidmove cidup itms orig + (ncoord,ntime) nlasso tsel + upact cinfo pcoord = do + xstate <- get + let (_,(x,y)) = runIdentity $ + skipIfNotInSamePage pnum geometry pcoord + (return (pcoord,prev)) return + nlasso = lasso |> (x,y) + hdlmodst = view hoodleModeState xstate + epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + cpn = view currentPageNum cinfo + hittestlasso = hltFilteredBy (hitLassoItem (nlasso |> orig)) itms + selectitms = fmapAL unNotHitted id hittestlasso + SelectState thdl = view hoodleModeState xstate + newpage = case epage of + Left pagebbox -> + let (mcurrlayer,npagebbox) = getCurrentLayerOrSet pagebbox + currlayer = maybe (error "newSelectLasso") id mcurrlayer + newlayer = GLayer (view gbuffer currlayer) (TEitherAlterHitted (Right selectitms)) + tpg = mkHPage npagebbox + npg = set (glayers.selectedLayer) newlayer tpg + in npg + Right tpage -> + let currlayer = view (glayers.selectedLayer) tpage + newlayer = GLayer (view gbuffer currlayer) (TEitherAlterHitted (Right selectitms)) + npage = set (glayers.selectedLayer) newlayer tpage + in npage + newthdl = set gselSelected (Just (cpn,newpage)) thdl + let ui = view gtkUIManager xstate + liftIO $ toggleCutCopyDelete ui (isAnyHitted selectitms) + put . set hoodleModeState (SelectState newthdl) + =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) + disconnect [cidmove, cidup] + invalidateAll + + diff --git a/src/Hoodle/Coroutine/Select/Clipboard.hs b/src/Hoodle/Coroutine/Select/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Select/Clipboard.hs @@ -0,0 +1,140 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Select.Clipboard +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +-- Clipboard action while dealing with selection +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Select.Clipboard where + +-- from other packages +import Control.Lens +import Control.Monad.State +import Graphics.UI.Gtk hiding (get,set) +-- from hoodle-platform +import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Queue +import Data.Hoodle.Generic +import Data.Hoodle.Select +import Data.Hoodle.Simple +import Graphics.Hoodle.Render.Item +import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest +-- from this package +import Hoodle.Accessor +import Hoodle.Coroutine.Draw +import Hoodle.Coroutine.Commit +import Hoodle.Coroutine.Mode +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Select +import Hoodle.ModelAction.Clipboard +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.Event +import Hoodle.Type.PageArrangement +import Hoodle.Type.HoodleState + +-- | +deleteSelection :: MainCoroutine () +deleteSelection = do + xstate <- get + case view hoodleModeState xstate of + SelectState thdl -> do + let Just (n,tpage) = view gselSelected thdl + slayer = view (glayers.selectedLayer) tpage + case unTEitherAlterHitted . view gitems $ slayer of + Left _ -> return () + Right alist -> do + let newlayer = Left . concat . getA $ alist + newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage + newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n + newxstate <- liftIO $ updatePageAll (SelectState newthdl) + . set hoodleModeState (SelectState newthdl) + $ xstate + commit newxstate + let ui = view gtkUIManager newxstate + liftIO $ toggleCutCopyDelete ui False + invalidateAll + _ -> return () + + + +-- | +cutSelection :: MainCoroutine () +cutSelection = copySelection >> deleteSelection + +-- | +copySelection :: MainCoroutine () +copySelection = do + updateXState copySelectionAction >> invalidateAll + where copySelectionAction xst = + boxAction (fsingle xst) . view currentCanvasInfo $ xst + fsingle xstate cinfo = maybe (return xstate) id $ do + let hdlmodst = view hoodleModeState xstate + let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + eitherMaybe epage `pipe` rItmsInActiveLyr + `pipe` (Right . liftIO . updateClipboard xstate . map rItem2Item . takeHitted) + where eitherMaybe (Left _) = Nothing + eitherMaybe (Right a) = Just a + x `pipe` a = x >>= eitherMaybe . a + infixl 6 `pipe` + +-- | +getClipFromGtk :: MainCoroutine (Maybe [Item]) +getClipFromGtk = do + let action = Left . ActionOrder $ + \evhandler -> do + hdltag <- liftIO $ atomNew "hoodle" + clipbd <- liftIO $ clipboardGet hdltag + liftIO $ clipboardRequestText clipbd (callback4Clip evhandler) + return ActionOrdered + modify (tempQueue %~ enqueue action) + go + where go = do r <- nextevent + case r of + GotClipboardContent cnt' -> return cnt' + _ -> go + + +-- | +pasteToSelection :: MainCoroutine () +pasteToSelection = do + mitms <- getClipFromGtk + case mitms of + Nothing -> return () + Just itms -> do + ritms <- liftIO (mapM cnstrctRItem itms) + modeChange ToSelectMode >>updateXState (pasteAction ritms) >> invalidateAll + where + pasteAction itms xst = boxAction (fsimple itms xst) . view currentCanvasInfo $ xst + fsimple itms xstate cinfo = do + geometry <- liftIO (getGeometry4CurrCvs xstate) + let pagenum = view currentPageNum cinfo + hdlmodst@(SelectState thdl) = view hoodleModeState xstate + nclipitms = adjustItemPosition4Paste geometry (PageNum pagenum) itms + epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + tpage = either mkHPage id epage + layerselect = view (glayers.selectedLayer) tpage + gbuf = view gbuffer layerselect + newlayerselect = case rItmsInActiveLyr tpage of + Left nitms -> (GLayer gbuf . TEitherAlterHitted . Right) (nitms :- Hitted nclipitms :- Empty) + Right alist -> (GLayer gbuf . TEitherAlterHitted . Right) + (concat (interleave id unHitted alist) + :- Hitted nclipitms + :- Empty ) + tpage' = set (glayers.selectedLayer) newlayerselect tpage + thdl' <- liftIO $ updateTempHoodleSelectIO thdl tpage' pagenum + xstate' <- liftIO $ updatePageAll (SelectState thdl') + . set hoodleModeState (SelectState thdl') + $ xstate + commit xstate' + let ui = view gtkUIManager xstate' + liftIO $ toggleCutCopyDelete ui True + return xstate' diff --git a/src/Hoodle/Coroutine/Window.hs b/src/Hoodle/Coroutine/Window.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Window.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Window +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.Window where + +import Control.Category +import Control.Lens +import Control.Monad.State +import Graphics.UI.Gtk hiding (get,set) +import qualified Data.IntMap as M +import Data.Maybe +import Data.Time.Clock +-- +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Generic +-- +import Hoodle.Type.Canvas +import Hoodle.Type.Event +import Hoodle.Type.Window +import Hoodle.Type.HoodleState +import Hoodle.Type.Coroutine +import Hoodle.Type.PageArrangement +import Hoodle.Type.Predefined +import Hoodle.Util +import Hoodle.ModelAction.Window +import Hoodle.ModelAction.Page +import Hoodle.Coroutine.Page +import Hoodle.Coroutine.Draw +import Hoodle.Accessor +-- +import Prelude hiding ((.),id) + +-- | canvas configure with general zoom update func + +canvasConfigureGenUpdate :: MainCoroutine () + -> CanvasId + -> CanvasDimension + -> MainCoroutine () +canvasConfigureGenUpdate updatefunc cid cdim + = (updateXState $ selectBoxAction fsingle fcont . getCanvasInfo cid ) + >> updatefunc + where fsingle cinfo = do + xstate <- get + let cinfo' = updateCanvasDimForSingle cdim cinfo + return $ setCanvasInfo (cid,CanvasSinglePage cinfo') xstate + fcont cinfo = do + xstate <- get + page <- getCurrentPageCvsId cid + let pdim = PageDimension (view gdimension page) + let cinfo' = updateCanvasDimForContSingle pdim cdim cinfo + return $ setCanvasInfo (cid,CanvasContPage cinfo') xstate + +-- | + +doCanvasConfigure :: CanvasId + -> CanvasDimension + -> MainCoroutine () +doCanvasConfigure = canvasConfigureGenUpdate canvasZoomUpdateAll + +-- | + +canvasConfigure' :: CanvasId -> CanvasDimension -> MainCoroutine () +canvasConfigure' cid cdim = do + xstate <- get + ctime <- liftIO getCurrentTime + maybe defaction (chkaction ctime) (view lastTimeCanvasConfigure xstate) + where defaction = do + ntime <- liftIO getCurrentTime + doCanvasConfigure cid cdim + updateXState (return . set lastTimeCanvasConfigure (Just ntime)) + chkaction ctime otime = do + let dtime = diffUTCTime ctime otime + if dtime > predefinedWinReconfTimeBound + then defaction + else return () + + +-- | + +eitherSplit :: SplitType -> MainCoroutine () +eitherSplit stype = do + xstate <- get + let cmap = getCanvasInfoMap xstate + currcid = getCurrentCanvasId xstate + newcid = newCanvasId cmap + fstate = view frameState xstate + enewfstate = splitWindow currcid (newcid,stype) fstate + case enewfstate of + Left _ -> return () + Right fstate' -> do + let cinfobox = maybeError "eitherSplit" . M.lookup currcid $ cmap + -- liftIO $ putStrLn "called here" + let rtwin = view rootWindow xstate + rtcntr = view rootContainer xstate + liftIO $ containerRemove rtcntr rtwin + (xstate'',win,fstate'') <- + liftIO $ constructFrame' cinfobox xstate fstate' + let xstate3 = set frameState fstate'' + . set rootWindow win + $ xstate'' + put xstate3 + liftIO $ boxPackEnd rtcntr win PackGrow 0 + liftIO $ widgetShowAll rtcntr + (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3) + xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4 + put xstate5 + canvasZoomUpdateAll + invalidateAll + -- fmap4CvsInfoBox f cinfobox -- \oldcinfo -> do + + +-- | + +deleteCanvas :: MainCoroutine () +deleteCanvas = do + xstate <- get + let cmap = getCanvasInfoMap xstate + currcid = getCurrentCanvasId xstate + fstate = view frameState xstate + enewfstate = removeWindow currcid fstate + case enewfstate of + Left _ -> return () + Right Nothing -> return () + Right (Just fstate') -> do + let -- cinfobox = maybeError "deleteCanvas" (M.lookup currcid cmap) + cmap' = M.delete currcid cmap + newcurrcid = maximum (M.keys cmap') + xstate0 <- changeCurrentCanvasId newcurrcid + let xstate1 = maybe xstate0 id $ setCanvasInfoMap cmap' xstate0 + put xstate1 + let rtwin = view rootWindow xstate1 + rtcntr = view rootContainer xstate1 + liftIO $ containerRemove rtcntr rtwin + (xstate'',win,fstate'') <- liftIO $ constructFrame xstate1 fstate' + let xstate3 = set frameState fstate'' + . set rootWindow win + $ xstate'' + put xstate3 + liftIO $ boxPackEnd rtcntr win PackGrow 0 + liftIO $ widgetShowAll rtcntr + (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3) + canvasZoomUpdateAll + xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4 + put xstate5 + invalidateAll + + +-- | +paneMoveStart :: MainCoroutine () +paneMoveStart = do + ev <- nextevent + case ev of + UpdateCanvas cid -> invalidateWithBuf cid >> paneMoveStart + PaneMoveEnd -> do + -- canvasZoomUpdateAll + return () + CanvasConfigure cid w' h'-> do + canvasConfigureGenUpdate canvasZoomUpdateBufAll cid (CanvasDimension (Dim w' h')) + >> paneMoveStart + _ -> paneMoveStart + + + +-- | + +paneMoved :: MainCoroutine () +paneMoved = do + liftIO $ putStrLn "pane moved called" + + + diff --git a/src/Hoodle/Device.hsc b/src/Hoodle/Device.hsc new file mode 100644 --- /dev/null +++ b/src/Hoodle/Device.hsc @@ -0,0 +1,189 @@ +{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Device +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +#include +#include "template-hsc-gtk2hs.h" + +module Hoodle.Device where + +import Hoodle.Config +import Data.Configurator.Types +import Control.Applicative +import Control.Monad.Reader +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.C +import Foreign.Storable +import Graphics.UI.Gtk +import Data.Int + +-- | + +data PointerType = Core | Stylus | Eraser + deriving (Show,Eq,Ord) + +-- | + +data PenButton = PenButton1 | PenButton2 | PenButton3 | EraserButton + deriving (Show,Eq,Ord) + +-- | + +data DeviceList = DeviceList { dev_core :: CInt + , dev_stylus :: CInt + , dev_eraser :: CInt } + deriving Show + +-- | + +data PointerCoord = PointerCoord { pointerType :: PointerType + , pointerX :: Double + , pointerY :: Double + , pointerZ :: Double + } + | NoPointerCoord + deriving (Show,Eq,Ord) + +-- | + +foreign import ccall "c_initdevice.h initdevice" c_initdevice + :: Ptr CInt -> Ptr CInt -> Ptr CInt -> CString -> CString -> CString -> IO () + +-- | + +initDevice :: Config -> IO DeviceList +initDevice cfg = do + (mcore,mstylus,meraser) <- getPenDevConfig cfg + putStrLn $ show mstylus + putStrLn $ show meraser + with 0 $ \pcore -> + with 0 $ \pstylus -> + with 0 $ \peraser -> do + pcorename <- case mcore of + Nothing -> newCString "Core Pointer" + Just core -> newCString core + pstylusname <- case mstylus of + Nothing -> newCString "stylus" + Just spen -> newCString spen + perasername <- case meraser of + Nothing -> newCString "eraser" + Just seraser -> newCString seraser + + c_initdevice pcore pstylus peraser pcorename pstylusname perasername + + core_val <- peek pcore + stylus_val <- peek pstylus + eraser_val <- peek peraser + return $ DeviceList core_val stylus_val eraser_val + +-- | + +getPointer :: DeviceList -> EventM t (Maybe PenButton,PointerCoord) +getPointer devlst = do + ptr <- ask + (_ty,btn,x,y,mdev,maxf) <- liftIO (getInfo ptr) + let rbtn | btn == 0 = Nothing + | btn == 1 = Just PenButton1 + | btn == 2 = Just PenButton2 + | btn == 3 = Just PenButton3 + | otherwise = Nothing + case mdev of + Nothing -> return (rbtn,PointerCoord Core x y 1.0) + Just dev -> case maxf of + Nothing -> return (rbtn,PointerCoord Core x y 1.0) + Just axf -> do + pcoord <- liftIO $ coord ptr x y dev axf + let rbtnfinal = case pointerType pcoord of + Eraser -> Just EraserButton + _ -> rbtn + + let tst = (rbtnfinal,pcoord) + -- (,) rbtn <$> (liftIO $ coord ptr x y dev axf) + -- liftIO $ print tst + return tst + where + getInfo ptr = do + (ty :: #{gtk2hs_type GdkEventType}) <- peek (castPtr ptr) + if ty `elem` [ #{const GDK_BUTTON_PRESS} + , #{const GDK_2BUTTON_PRESS} + , #{const GDK_3BUTTON_PRESS} + , #{const GDK_BUTTON_RELEASE}] + then do + (x :: #{gtk2hs_type gdouble}) <- #{peek GdkEventButton, x} ptr + (y :: #{gtk2hs_type gdouble}) <- #{peek GdkEventButton, y} ptr + (btn :: #{gtk2hs_type gint}) <- #{peek GdkEventButton, button} ptr + (dev :: CInt) <- #{peek GdkEventButton, device} ptr + let axisfunc = #{peek GdkEventButton, axes} + return (ty,btn,realToFrac x,realToFrac y,Just dev,Just axisfunc) + else if ty `elem` [ #{const GDK_SCROLL} ] + then do + (x :: #{gtk2hs_type gdouble}) <- #{peek GdkEventScroll, x} ptr + (y :: #{gtk2hs_type gdouble}) <- #{peek GdkEventScroll, y} ptr + (dev :: CInt) <- #{peek GdkEventScroll, device} ptr + return (ty,0,realToFrac x, realToFrac y,Just dev,Nothing) + else if ty `elem` [ #{const GDK_MOTION_NOTIFY} ] + then do + (x :: #{gtk2hs_type gdouble}) <- #{peek GdkEventMotion, x} ptr + (y :: #{gtk2hs_type gdouble}) <- #{peek GdkEventMotion, y} ptr + (dev :: CInt) <- #{peek GdkEventMotion, device} ptr + let axisfunc = #{peek GdkEventMotion, axes} + return (ty,0,realToFrac x, realToFrac y,Just dev,Just axisfunc) + else if ty `elem` [ #{const GDK_ENTER_NOTIFY}, + #{const GDK_LEAVE_NOTIFY}] + then do + (x :: #{gtk2hs_type gdouble}) <- #{peek GdkEventCrossing, x} ptr + (y :: #{gtk2hs_type gdouble}) <- #{peek GdkEventCrossing, y} ptr + return (ty,0,realToFrac x, realToFrac y,Nothing,Nothing) + else error ("eventCoordinates: none for event type "++show ty) + + coord ptr x y device axf + | device == dev_core devlst = return $ PointerCoord Core x y 1.0 + | device == dev_stylus devlst = do + (ptrax :: Ptr CDouble ) <- axf ptr + (wacomx :: Double) <- peekByteOff ptrax 0 + (wacomy :: Double) <- peekByteOff ptrax 8 + (wacomz :: Double) <- peekByteOff ptrax 16 + return $ PointerCoord Stylus wacomx wacomy wacomz + | device == dev_eraser devlst = do + (ptrax :: Ptr CDouble ) <- axf ptr + (wacomx :: Double) <- peekByteOff ptrax 0 + (wacomy :: Double) <- peekByteOff ptrax 8 + (wacomz :: Double) <- peekByteOff ptrax 16 + return $ PointerCoord Eraser wacomx wacomy wacomz + | otherwise = return $ PointerCoord Core x y 1.0 + +-- | + +wacomCoordConvert :: WidgetClass self => self + -> (Double,Double) + -> IO (Double,Double) +wacomCoordConvert canvas (x,y)= do + win <- widgetGetDrawWindow canvas + (x0,y0) <- drawWindowGetOrigin win + screen <- widgetGetScreen canvas + (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen + return (fromIntegral ws*x-fromIntegral x0,fromIntegral hs*y-fromIntegral y0) + +-- | + +wacomPConvert :: WidgetClass self => self + -> PointerCoord + -> IO (Double,Double) +wacomPConvert canvas pcoord = do + let (px,py) = (,) <$> pointerX <*> pointerY $ pcoord + case pointerType pcoord of + Core -> return (px,py) + _ -> do + wacomCoordConvert canvas (px,py) + diff --git a/src/Hoodle/GUI.hs b/src/Hoodle/GUI.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/GUI.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.GUI +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.GUI where + +import Control.Category +import Control.Exception +import Control.Lens +import Control.Monad.Trans +import qualified Data.IntMap as M +import Data.Maybe +-- import Data.Time +import Graphics.UI.Gtk hiding (get,set) +import System.Environment +import System.FilePath +import System.IO +-- +-- import Control.Monad.Trans.Crtn.EventHandler +-- from this package +import Hoodle.Config +import Hoodle.Coroutine +import Hoodle.Coroutine.Callback +import Hoodle.Device +import Hoodle.ModelAction.Window +import Hoodle.Script.Hook +import Hoodle.Type.Canvas +import Hoodle.Type.Event +import Hoodle.Type.HoodleState +-- +import Prelude hiding ((.),id,catch) + +-- | +startGUI :: Maybe FilePath -> Maybe Hook -> IO () +startGUI mfname mhook = do + initGUI + window <- windowNew + windowSetDefaultSize window 800 400 + cfg <- loadConfigFile + devlst <- initDevice cfg + maxundo <- getMaxUndo cfg >>= + \mmax -> maybe (return 50) (return . id) mmax + (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo + setTitleFromFileName st0 + xinputbool <- getXInputConfig cfg + agr <- uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group? " + y:_ -> return y + uxinputa <- actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> + return (castToToggleAction x) + toggleActionSetActive uxinputa xinputbool + let canvases = map (getDrawAreaFromBox) . M.elems . getCanvasInfoMap $ st0 + if xinputbool + then mapM_ (flip widgetSetExtensionEvents [ExtensionEventsAll]) canvases + else mapM_ (flip widgetSetExtensionEvents [ExtensionEventsNone]) canvases + maybeMenubar <- uiManagerGetWidget ui "/ui/menubar" + let menubar = case maybeMenubar of + Just x -> x + Nothing -> error "cannot get menubar from string" + + maybeToolbar1 <- uiManagerGetWidget ui "/ui/toolbar1" + let toolbar1 = case maybeToolbar1 of + Just x -> x + Nothing -> error "cannot get toolbar from string" + maybeToolbar2 <- uiManagerGetWidget ui "/ui/toolbar2" + let toolbar2 = case maybeToolbar2 of + Just x -> x + Nothing -> error "cannot get toolbar from string" + containerAdd window vbox + boxPackStart vbox menubar PackNatural 0 + boxPackStart vbox toolbar1 PackNatural 0 + boxPackStart vbox toolbar2 PackNatural 0 + boxPackEnd vbox (view rootWindow st0) PackGrow 0 + -- cursorDot <- cursorNew BlankCursor + window `on` deleteEvent $ do + liftIO $ eventHandler tref (Menu MenuQuit) + return True + widgetShowAll window + let mainaction = do eventHandler tref Initialized + mainGUI + mainaction `catch` \(_e :: SomeException) -> do + homepath <- getEnv "HOME" + outh <- openFile (homepath ".hoodle.d" "error.log") WriteMode + hPutStrLn outh "error occured" + hClose outh + return () + + + + diff --git a/src/Hoodle/GUI/Menu.hs b/src/Hoodle/GUI/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/GUI/Menu.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE QuasiQuotes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.GUI.Menu +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +-- Construct hoodle menus +-- +----------------------------------------------------------------------------- + +module Hoodle.GUI.Menu where + +-- from other packages +import Control.Category +import Data.Maybe +import Graphics.UI.Gtk hiding (set,get) +import qualified Graphics.UI.Gtk as Gtk (set) +import System.FilePath +-- from hoodle-platform +-- import Control.Monad.Trans.Crtn.EventHandler +import Data.Hoodle.Predefined +-- from this package +import Hoodle.Coroutine.Callback +import Hoodle.Type +import Hoodle.Type.Clipboard +import Hoodle.Util.Verbatim +-- +import Prelude hiding ((.),id) +import Paths_hoodle_core + +-- | + +justMenu :: MenuEvent -> Maybe MyEvent +justMenu = Just . Menu + +-- | + +uiDeclTest :: String +uiDeclTest = [verbatim| + + + + + + + + + +|] + +-- | + +uiDecl :: String +uiDecl = [verbatim| + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +|] + +iconList :: [ (String,String) ] +iconList = [ ("fullscreen.png" , "myfullscreen") + , ("pencil.png" , "mypen") + , ("eraser.png" , "myeraser") + , ("highlighter.png", "myhighlighter") + , ("text-tool.png" , "mytext") + , ("shapes.png" , "myshapes") + , ("ruler.png" , "myruler") + , ("lasso.png" , "mylasso") + , ("rect-select.png", "myrectselect") + , ("stretch.png" , "mystretch") + , ("hand.png" , "myhand") + , ("recycled.png" , "mydefault") + , ("default-pen.png", "mydefaultpen") + , ("thin.png" , "mythin") + , ("medium.png" , "mymedium") + , ("thick.png" , "mythick") + , ("black.png" , "myblack") + , ("blue.png" , "myblue") + , ("red.png" , "myred") + , ("green.png" , "mygreen") + , ("gray.png" , "mygray") + , ("lightblue.png" , "mylightblue") + , ("lightgreen.png" , "mylightgreen") + , ("magenta.png" , "mymagenta") + , ("orange.png" , "myorange") + , ("yellow.png" , "myyellow") + , ("white.png" , "mywhite") + ] + +-- | + +viewmods :: [RadioActionEntry] +viewmods = [ RadioActionEntry "CONTA" "Continuous" Nothing Nothing Nothing 0 + , RadioActionEntry "ONEPAGEA" "One Page" Nothing Nothing Nothing 1 + ] + +-- | + +pointmods :: [RadioActionEntry] +pointmods = [ RadioActionEntry "PENVERYFINEA" "Very fine" Nothing Nothing Nothing 0 + , RadioActionEntry "PENFINEA" "Fine" (Just "mythin") Nothing Nothing 1 + + , RadioActionEntry "PENTHICKA" "Thick" (Just "mythick") Nothing Nothing 3 + , RadioActionEntry "PENVERYTHICKA" "Very Thick" Nothing Nothing Nothing 4 + , RadioActionEntry "PENULTRATHICKA" "Ultra Thick" Nothing Nothing Nothing 5 + , RadioActionEntry "PENMEDIUMA" "Medium" (Just "mymedium") Nothing Nothing 2 + ] + +-- | + +penmods :: [RadioActionEntry] +penmods = [ RadioActionEntry "PENA" "Pen" (Just "mypen") Nothing Nothing 0 + , RadioActionEntry "ERASERA" "Eraser" (Just "myeraser") Nothing Nothing 1 + , RadioActionEntry "HIGHLTA" "Highlighter" (Just "myhighlighter") Nothing Nothing 2 + , RadioActionEntry "TEXTA" "Text" (Just "mytext") Nothing Nothing 3 + , RadioActionEntry "SELREGNA" "Select Region" (Just "mylasso") Nothing Nothing 4 + , RadioActionEntry "SELRECTA" "Select Rectangle" (Just "myrectselect") Nothing Nothing 5 + , RadioActionEntry "VERTSPA" "Vertical Space" (Just "mystretch") Nothing Nothing 6 + , RadioActionEntry "HANDA" "Hand Tool" (Just "myhand") Nothing Nothing 7 + ] + +-- | + +colormods :: [RadioActionEntry] +colormods = [ RadioActionEntry "BLUEA" "Blue" (Just "myblue") Nothing Nothing 1 + , RadioActionEntry "REDA" "Red" (Just "myred") Nothing Nothing 2 + , RadioActionEntry "GREENA" "Green" (Just "mygreen") Nothing Nothing 3 + , RadioActionEntry "GRAYA" "Gray" (Just "mygray") Nothing Nothing 4 + , RadioActionEntry "LIGHTBLUEA" "Lightblue" (Just "mylightblue") Nothing Nothing 5 + , RadioActionEntry "LIGHTGREENA" "Lightgreen" (Just "mylightgreen") Nothing Nothing 6 + , RadioActionEntry "MAGENTAA" "Magenta" (Just "mymagenta") Nothing Nothing 7 + , RadioActionEntry "ORANGEA" "Orange" (Just "myorange") Nothing Nothing 8 + , RadioActionEntry "YELLOWA" "Yellow" (Just "myyellow") Nothing Nothing 9 + , RadioActionEntry "WHITEA" "White" (Just "mywhite") Nothing Nothing 10 + , RadioActionEntry "BLACKA" "Black" (Just "myblack") Nothing Nothing 0 + ] + +-- | + +iconResourceAdd :: IconFactory -> FilePath -> (FilePath, StockId) + -> IO () +iconResourceAdd iconfac resdir (fp,stid) = do + myIconSource <- iconSourceNew + iconSourceSetFilename myIconSource (resdir fp) + iconSourceSetSize myIconSource IconSizeLargeToolbar + myIconSourceSmall <- iconSourceNew + iconSourceSetFilename myIconSourceSmall (resdir fp) + iconSourceSetSize myIconSource IconSizeMenu + myIconSet <- iconSetNew + iconSetAddSource myIconSet myIconSource + iconSetAddSource myIconSet myIconSourceSmall + iconFactoryAdd iconfac stid myIconSet + +-- | + +actionNewAndRegisterRef :: EventVar + -> String -> String + -> Maybe String -> Maybe StockId + -> Maybe MyEvent + -> IO Action +actionNewAndRegisterRef evar name label tooltip stockId myevent = do + a <- actionNew name label tooltip stockId + case myevent of + Nothing -> return a + Just ev -> do + a `on` actionActivated $ do + eventHandler evar ev + return a + +-- | + +getMenuUI :: EventVar -> IO UIManager +getMenuUI evar = do + let actionNewAndRegister = actionNewAndRegisterRef evar + -- icons + myiconfac <- iconFactoryNew + iconFactoryAddDefault myiconfac + resDir <- getDataDir >>= return . ( "resource") + mapM_ (iconResourceAdd myiconfac resDir) iconList + fma <- actionNewAndRegister "FMA" "File" Nothing Nothing Nothing + ema <- actionNewAndRegister "EMA" "Edit" Nothing Nothing Nothing + vma <- actionNewAndRegister "VMA" "View" Nothing Nothing Nothing + jma <- actionNewAndRegister "JMA" "Journal" Nothing Nothing Nothing + tma <- actionNewAndRegister "TMA" "Tools" Nothing Nothing Nothing + oma <- actionNewAndRegister "OMA" "Options" Nothing Nothing Nothing + hma <- actionNewAndRegister "HMA" "Help" Nothing Nothing Nothing + + -- file menu + newa <- actionNewAndRegister "NEWA" "New" (Just "Just a Stub") (Just stockNew) (justMenu MenuNew) + annpdfa <- actionNewAndRegister "ANNPDFA" "Annotate PDF" (Just "Just a Stub") Nothing (justMenu MenuAnnotatePDF) + ldimga <- actionNewAndRegister "LDIMGA" "Load Image" (Just "Just a Stub") Nothing (justMenu MenuLoadImage) + opena <- actionNewAndRegister "OPENA" "Open" (Just "Just a Stub") (Just stockOpen) (justMenu MenuOpen) + savea <- actionNewAndRegister "SAVEA" "Save" (Just "Just a Stub") (Just stockSave) (justMenu MenuSave) + saveasa <- actionNewAndRegister "SAVEASA" "Save As" (Just "Just a Stub") (Just stockSaveAs) (justMenu MenuSaveAs) + reloada <- actionNewAndRegister "RELOADA" "Reload File" (Just "Just a Stub") Nothing (justMenu MenuReload) + recenta <- actionNewAndRegister "RECENTA" "Recent Document" (Just "Just a Stub") Nothing (justMenu MenuRecentDocument) + printa <- actionNewAndRegister "PRINTA" "Print" (Just "Just a Stub") Nothing (justMenu MenuPrint) + exporta <- actionNewAndRegister "EXPORTA" "Export" (Just "Just a Stub") Nothing (justMenu MenuExport) + quita <- actionNewAndRegister "QUITA" "Quit" (Just "Just a Stub") (Just stockQuit) (justMenu MenuQuit) + + -- edit menu + undoa <- actionNewAndRegister "UNDOA" "Undo" (Just "Just a Stub") (Just stockUndo) (justMenu MenuUndo) + redoa <- actionNewAndRegister "REDOA" "Redo" (Just "Just a Stub") (Just stockRedo) (justMenu MenuRedo) + cuta <- actionNewAndRegister "CUTA" "Cut" (Just "Just a Stub") (Just stockCut) (justMenu MenuCut) + copya <- actionNewAndRegister "COPYA" "Copy" (Just "Just a Stub") (Just stockCopy) (justMenu MenuCopy) + pastea <- actionNewAndRegister "PASTEA" "Paste" (Just "Just a Stub") (Just stockPaste) (justMenu MenuPaste) + deletea <- actionNewAndRegister "DELETEA" "Delete" (Just "Just a Stub") (Just stockDelete) (justMenu MenuDelete) + -- netcopya <- actionNewAndRegister "NETCOPYA" "Copy to NetworkClipboard" (Just "Just a Stub") Nothing (justMenu MenuNetCopy) + -- netpastea <- actionNewAndRegister "NETPASTEA" "Paste from NetworkClipboard" (Just "Just a Stub") Nothing (justMenu MenuNetPaste) + + -- view menu + fscra <- actionNewAndRegister "FSCRA" "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen) + zooma <- actionNewAndRegister "ZOOMA" "Zoom" (Just "Just a Stub") Nothing Nothing -- (justMenu MenuZoom) + zmina <- actionNewAndRegister "ZMINA" "Zoom In" (Just "Zoom In") (Just stockZoomIn) (justMenu MenuZoomIn) + zmouta <- actionNewAndRegister "ZMOUTA" "Zoom Out" (Just "Zoom Out") (Just stockZoomOut) (justMenu MenuZoomOut) + nrmsizea <- actionNewAndRegister "NRMSIZEA" "Normal Size" (Just "Normal Size") (Just stockZoom100) (justMenu MenuNormalSize) + pgwdtha <- actionNewAndRegister "PGWDTHA" "Page Width" (Just "Page Width") (Just stockZoomFit) (justMenu MenuPageWidth) + pgheighta <- actionNewAndRegister "PGHEIGHTA" "Page Height" (Just "Page Height") Nothing (justMenu MenuPageHeight) + setzma <- actionNewAndRegister "SETZMA" "Set Zoom" (Just "Set Zoom") (Just stockFind) (justMenu MenuSetZoom) + fstpagea <- actionNewAndRegister "FSTPAGEA" "First Page" (Just "Just a Stub") (Just stockGotoFirst) (justMenu MenuFirstPage) + prvpagea <- actionNewAndRegister "PRVPAGEA" "Previous Page" (Just "Just a Stub") (Just stockGoBack) (justMenu MenuPreviousPage) + nxtpagea <- actionNewAndRegister "NXTPAGEA" "Next Page" (Just "Just a Stub") (Just stockGoForward) (justMenu MenuNextPage) + lstpagea <- actionNewAndRegister "LSTPAGEA" "Last Page" (Just "Just a Stub") (Just stockGotoLast) (justMenu MenuLastPage) + shwlayera <- actionNewAndRegister "SHWLAYERA" "Show Layer" (Just "Just a Stub") Nothing (justMenu MenuShowLayer) + hidlayera <- actionNewAndRegister "HIDLAYERA" "Hide Layer" (Just "Just a Stub") Nothing (justMenu MenuHideLayer) + hsplita <- actionNewAndRegister "HSPLITA" "Horizontal Split" (Just "horizontal split") Nothing (justMenu MenuHSplit) + vsplita <- actionNewAndRegister "VSPLITA" "Vertical Split" (Just "vertical split") Nothing (justMenu MenuVSplit) + delcvsa <- actionNewAndRegister "DELCVSA" "Delete Current Canvas" (Just "delete current canvas") Nothing (justMenu MenuDelCanvas) + + -- journal menu + newpgba <- actionNewAndRegister "NEWPGBA" "New Page Before" (Just "Just a Stub") Nothing (justMenu MenuNewPageBefore) + newpgaa <- actionNewAndRegister "NEWPGAA" "New Page After" (Just "Just a Stub") Nothing (justMenu MenuNewPageAfter) + newpgea <- actionNewAndRegister "NEWPGEA" "New Page At End" (Just "Just a Stub") Nothing (justMenu MenuNewPageAtEnd) + delpga <- actionNewAndRegister "DELPGA" "Delete Page" (Just "Just a Stub") Nothing (justMenu MenuDeletePage) + newlyra <- actionNewAndRegister "NEWLYRA" "New Layer" (Just "Just a Stub") Nothing (justMenu MenuNewLayer) + nextlayera <- actionNewAndRegister "NEXTLAYERA" "Next Layer" (Just "Just a Stub") Nothing (justMenu MenuNextLayer) + prevlayera <- actionNewAndRegister "PREVLAYERA" "Prev Layer" (Just "Just a Stub") Nothing (justMenu MenuPrevLayer) + gotolayera <- actionNewAndRegister "GOTOLAYERA" "Goto Layer" (Just "Just a Stub") Nothing (justMenu MenuGotoLayer) + dellyra <- actionNewAndRegister "DELLYRA" "Delete Layer" (Just "Just a Stub") Nothing (justMenu MenuDeleteLayer) + ppsizea <- actionNewAndRegister "PPSIZEA" "Paper Size" (Just "Just a Stub") Nothing (justMenu MenuPaperSize) + ppclra <- actionNewAndRegister "PPCLRA" "Paper Color" (Just "Just a Stub") Nothing (justMenu MenuPaperColor) + ppstya <- actionNewAndRegister "PPSTYA" "Paper Style" (Just "Just a Stub") Nothing (justMenu MenuPaperStyle) + apallpga<- actionNewAndRegister "APALLPGA" "Apply To All Pages" (Just "Just a Stub") Nothing (justMenu MenuApplyToAllPages) + ldbkga <- actionNewAndRegister "LDBKGA" "Load Background" (Just "Just a Stub") Nothing (justMenu MenuLoadBackground) + bkgscrshta <- actionNewAndRegister "BKGSCRSHTA" "Background Screenshot" (Just "Just a Stub") Nothing (justMenu MenuBackgroundScreenshot) + defppa <- actionNewAndRegister "DEFPPA" "Default Paper" (Just "Just a Stub") Nothing (justMenu MenuDefaultPaper) + setdefppa <- actionNewAndRegister "SETDEFPPA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultPaper) + + -- tools menu + shpreca <- actionNewAndRegister "SHPRECA" "Shape Recognizer" (Just "Just a Stub") (Just "myshapes") (justMenu MenuShapeRecognizer) + rulera <- actionNewAndRegister "RULERA" "Ruler" (Just "Just a Stub") (Just "myruler") (justMenu MenuRuler) + -- selregna <- actionNewAndRegister "SELREGNA" "Select Region" (Just "Just a Stub") (Just "mylasso") (justMenu MenuSelectRegion) + -- selrecta <- actionNewAndRegister "SELRECTA" "Select Rectangle" (Just "Just a Stub") (Just "myrectselect") (justMenu MenuSelectRectangle) + -- vertspa <- actionNewAndRegister "VERTSPA" "Vertical Space" (Just "Just a Stub") (Just "mystretch") (justMenu MenuVerticalSpace) + -- handa <- actionNewAndRegister "HANDA" "Hand Tool" (Just "Just a Stub") (Just "myhand") (justMenu MenuHandTool) + clra <- actionNewAndRegister "CLRA" "Color" (Just "Just a Stub") Nothing Nothing + penopta <- actionNewAndRegister "PENOPTA" "Pen Options" (Just "Just a Stub") Nothing (justMenu MenuPenOptions) + erasropta <- actionNewAndRegister "ERASROPTA" "Eraser Options" (Just "Just a Stub") Nothing (justMenu MenuEraserOptions) + hiltropta <- actionNewAndRegister "HILTROPTA" "Highlighter Options" (Just "Just a Stub") Nothing (justMenu MenuHighlighterOptions) + txtfnta <- actionNewAndRegister "TXTFNTA" "Text Font" (Just "Just a Stub") Nothing (justMenu MenuTextFont) + defpena <- actionNewAndRegister "DEFPENA" "Default Pen" (Just "Just a Stub") (Just "mydefaultpen") (justMenu MenuDefaultPen) + defersra <- actionNewAndRegister "DEFERSRA" "Default Eraser" (Just "Just a Stub") Nothing (justMenu MenuDefaultEraser) + defhiltra <- actionNewAndRegister "DEFHILTRA" "Default Highlighter" (Just "Just a Stub") Nothing (justMenu MenuDefaultHighlighter) + deftxta <- actionNewAndRegister "DEFTXTA" "Default Text" (Just "Just a Stub") Nothing (justMenu MenuDefaultText) + setdefopta <- actionNewAndRegister "SETDEFOPTA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultOption) + relauncha <- actionNewAndRegister "RELAUNCHA" "Relaunch Application" (Just "Just a Stub") Nothing (justMenu MenuRelaunch) + + -- options menu + uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing + uxinputa `on` actionToggled $ do + eventHandler evar (Menu MenuUseXInput) +-- AndRegister "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing (justMenu MenuUseXInput) + dcrdcorea <- actionNewAndRegister "DCRDCOREA" "Discard Core Events" (Just "Just a Stub") Nothing (justMenu MenuDiscardCoreEvents) + ersrtipa <- actionNewAndRegister "ERSRTIPA" "Eraser Tip" (Just "Just a Stub") Nothing (justMenu MenuEraserTip) + pressrsensa <- toggleActionNew "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing + pressrsensa `on` actionToggled $ do + eventHandler evar (Menu MenuPressureSensitivity) +-- AndRegister "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing (justMenu MenuUseXInput) + + + + + pghilta <- actionNewAndRegister "PGHILTA" "Page Highlight" (Just "Just a Stub") Nothing (justMenu MenuPageHighlight) + mltpgvwa <- actionNewAndRegister "MLTPGVWA" "Multiple Page View" (Just "Just a Stub") Nothing (justMenu MenuMultiplePageView) + mltpga <- actionNewAndRegister "MLTPGA" "Multiple Pages" (Just "Just a Stub") Nothing (justMenu MenuMultiplePages) + btn2mapa <- actionNewAndRegister "BTN2MAPA" "Button 2 Mapping" (Just "Just a Stub") Nothing (justMenu MenuButton2Mapping) + btn3mapa <- actionNewAndRegister "BTN3MAPA" "Button 3 Mapping" (Just "Just a Stub") Nothing (justMenu MenuButton3Mapping) + antialiasbmpa <- actionNewAndRegister "ANTIALIASBMPA" "Antialiased Bitmaps" (Just "Just a Stub") Nothing (justMenu MenuAntialiasedBitmaps) + prgrsbkga <- actionNewAndRegister "PRGRSBKGA" "Progressive Backgrounds" (Just "Just a Stub") Nothing (justMenu MenuProgressiveBackgrounds) + prntpprulea <- actionNewAndRegister "PRNTPPRULEA" "Print Paper Ruling" (Just "Just a Stub") Nothing (justMenu MenuPrintPaperRuling) + lfthndscrbra <- actionNewAndRegister "LFTHNDSCRBRA" "Left-Handed Scrollbar" (Just "Just a Stub") Nothing (justMenu MenuLeftHandedScrollbar) + shrtnmenua <- actionNewAndRegister "SHRTNMENUA" "Shorten Menus" (Just "Just a Stub") Nothing (justMenu MenuShortenMenus) + autosaveprefa <- actionNewAndRegister "AUTOSAVEPREFA" "Auto-Save Preferences" (Just "Just a Stub") Nothing (justMenu MenuAutoSavePreferences) + saveprefa <- actionNewAndRegister "SAVEPREFA" "Save Preferences" (Just "Just a Stub") Nothing (justMenu MenuSavePreferences) + + -- help menu + abouta <- actionNewAndRegister "ABOUTA" "About" (Just "Just a Stub") Nothing (justMenu MenuAbout) + + -- others + defaulta <- actionNewAndRegister "DEFAULTA" "Default" (Just "Default") (Just "mydefault") (justMenu MenuDefault) + + agr <- actionGroupNew "AGR" + mapM_ (actionGroupAddAction agr) + [fma,ema,vma,jma,tma,oma,hma] + mapM_ (actionGroupAddAction agr) + [ undoa, redoa, cuta, copya, pastea, deletea ] + -- actionGroupAddActionWithAccel agr undoa (Just "z") + mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing) + [ newa, annpdfa, ldimga, opena, savea, saveasa, reloada, recenta, printa, exporta, quita + {- , netcopya, netpastea -} + , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma + , fstpagea, prvpagea, nxtpagea, lstpagea, shwlayera, hidlayera + , hsplita, vsplita, delcvsa + , newpgba, newpgaa, newpgea, delpga, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra + , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa + , shpreca, rulera, clra, penopta + , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta + , setdefopta, relauncha + , dcrdcorea, ersrtipa, pghilta, mltpgvwa + , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea + , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa + , abouta + , defaulta + ] + + actionGroupAddAction agr uxinputa + actionGroupAddAction agr pressrsensa + -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode evar) + actionGroupAddRadioActions agr viewmods 0 (const (return ())) + + + actionGroupAddRadioActions agr pointmods 0 (assignPoint evar) + actionGroupAddRadioActions agr penmods 0 (assignPenMode evar) + actionGroupAddRadioActions agr colormods 0 (assignColor evar) + + let disabledActions = + [ recenta, printa {- , exporta-} + , cuta, copya, {- pastea, -} deletea + , fscra, setzma + , shwlayera, hidlayera + , newpgea, {- delpga, -} ppsizea, ppclra + , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa + , shpreca, rulera + , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta + , setdefopta + , dcrdcorea, ersrtipa, pghilta, mltpgvwa + , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea + , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa + , abouta + , defaulta + ] + enabledActions = + [ opena, savea, saveasa, reloada, quita, pastea, fstpagea, prvpagea, nxtpagea, lstpagea + , clra, penopta, zooma, nrmsizea, pgwdtha + ] + -- + mapM_ (\x->actionSetSensitive x True) enabledActions + mapM_ (\x->actionSetSensitive x False) disabledActions + -- + -- + -- radio actions + -- + ui <- uiManagerNew + uiManagerAddUiFromString ui uiDecl + uiManagerInsertActionGroup ui agr 0 + -- Just ra1 <- actionGroupGetAction agr "ONEPAGEA" + -- Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1] + Just ra2 <- actionGroupGetAction agr "PENFINEA" + Gtk.set (castToRadioAction ra2) [radioActionCurrentValue := 2] + Just ra3 <- actionGroupGetAction agr "SELREGNA" + actionSetSensitive ra3 True + Just ra4 <- actionGroupGetAction agr "VERTSPA" + actionSetSensitive ra4 False + Just ra5 <- actionGroupGetAction agr "HANDA" + actionSetSensitive ra5 False + Just ra6 <- actionGroupGetAction agr "CONTA" + actionSetSensitive ra6 True + Just toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1" + toolbarSetStyle (castToToolbar toolbar1) ToolbarIcons + toolbarSetIconSize (castToToolbar toolbar1) IconSizeSmallToolbar + Just toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2" + toolbarSetStyle (castToToolbar toolbar2) ToolbarIcons + toolbarSetIconSize (castToToolbar toolbar2) IconSizeSmallToolbar + return ui + +-- | +assignViewMode :: EventVar -> RadioAction -> IO () +assignViewMode evar a = viewModeToMyEvent a >>= eventHandler evar + +-- | +assignPenMode :: EventVar -> RadioAction -> IO () +assignPenMode evar a = do + v <- radioActionGetCurrentValue a + eventHandler evar (AssignPenMode (int2PenType v)) + + +-- | +assignColor :: EventVar -> RadioAction -> IO () +assignColor evar a = do + v <- radioActionGetCurrentValue a + let c = int2Color v + eventHandler evar (PenColorChanged c) + +-- | +assignPoint :: EventVar -> RadioAction -> IO () +assignPoint evar a = do + v <- radioActionGetCurrentValue a + eventHandler evar (PenWidthChanged v) + +-- | +int2PenType :: Int -> Either PenType SelectType +int2PenType 0 = Left PenWork +int2PenType 1 = Left EraserWork +int2PenType 2 = Left HighlighterWork +int2PenType 3 = Left TextWork +int2PenType 4 = Right SelectRegionWork +int2PenType 5 = Right SelectRectangleWork +int2PenType 6 = Right SelectVerticalSpaceWork +int2PenType 7 = Right SelectHandToolWork +int2PenType _ = error "No such pentype" + +-- | +int2Point :: PenType -> Int -> Double +int2Point PenWork 0 = predefined_veryfine +int2Point PenWork 1 = predefined_fine +int2Point PenWork 2 = predefined_medium +int2Point PenWork 3 = predefined_thick +int2Point PenWork 4 = predefined_verythick +int2Point PenWork 5 = predefined_ultrathick +int2Point HighlighterWork 0 = predefined_highlighter_veryfine +int2Point HighlighterWork 1 = predefined_highlighter_fine +int2Point HighlighterWork 2 = predefined_highlighter_medium +int2Point HighlighterWork 3 = predefined_highlighter_thick +int2Point HighlighterWork 4 = predefined_highlighter_verythick +int2Point HighlighterWork 5 = predefined_highlighter_ultrathick +int2Point EraserWork 0 = predefined_eraser_veryfine +int2Point EraserWork 1 = predefined_eraser_fine +int2Point EraserWork 2 = predefined_eraser_medium +int2Point EraserWork 3 = predefined_eraser_thick +int2Point EraserWork 4 = predefined_eraser_verythick +int2Point EraserWork 5 = predefined_eraser_ultrathick +int2Point TextWork 0 = predefined_veryfine +int2Point TextWork 1 = predefined_fine +int2Point TextWork 2 = predefined_medium +int2Point TextWork 3 = predefined_thick +int2Point TextWork 4 = predefined_verythick +int2Point TextWork 5 = predefined_ultrathick +int2Point _ _ = error "No such point" + +-- | +int2Color :: Int -> PenColor +int2Color 0 = ColorBlack +int2Color 1 = ColorBlue +int2Color 2 = ColorRed +int2Color 3 = ColorGreen +int2Color 4 = ColorGray +int2Color 5 = ColorLightBlue +int2Color 6 = ColorLightGreen +int2Color 7 = ColorMagenta +int2Color 8 = ColorOrange +int2Color 9 = ColorYellow +int2Color 10 = ColorWhite +int2Color _ = error "No such color" diff --git a/src/Hoodle/ModelAction/Adjustment.hs b/src/Hoodle/ModelAction/Adjustment.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Adjustment.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Adjustment +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Adjustment where + +-- from other package +import Graphics.UI.Gtk +-- from hoodle-platform +import Data.Hoodle.BBox (BBox(..)) +import Data.Hoodle.Simple (Dimension(..)) +-- from this package +import Hoodle.Type.PageArrangement +import Hoodle.View.Coordinate + +-- | adjust values, upper limit and page size according to canvas geometry + +adjustScrollbarWithGeometry :: CanvasGeometry + -> ((Adjustment,Maybe (ConnectId Adjustment)) + ,(Adjustment,Maybe (ConnectId Adjustment))) + -> IO () +adjustScrollbarWithGeometry geometry ((hadj,mconnidh),(vadj,mconnidv)) = do + let DesktopDimension (Dim w h) = desktopDim geometry + ViewPortBBox (BBox (x0,y0) (x1,y1)) = canvasViewPort geometry + xsize = x1-x0 + ysize = y1-y0 + maybe (return ()) signalBlock mconnidh + maybe (return ()) signalBlock mconnidv + adjustmentSetUpper hadj w + adjustmentSetUpper vadj h + adjustmentSetValue hadj x0 + adjustmentSetValue vadj y0 + adjustmentSetPageSize hadj (min xsize w) + adjustmentSetPageSize vadj (min ysize h) + maybe (return ()) signalUnblock mconnidh + maybe (return ()) signalUnblock mconnidv + +-- | + +setAdjustments :: ((Adjustment,Maybe (ConnectId Adjustment)) + ,(Adjustment,Maybe (ConnectId Adjustment))) + -> (Double,Double) + -> (Double,Double) + -> (Double,Double) + -> (Double,Double) + -> IO () +setAdjustments ((hadj,mconnidh),(vadj,mconnidv)) + (upperx,uppery) (lowerx,lowery) + (valuex,valuey) (pagex,pagey) = do + maybe (return ()) signalBlock mconnidh + maybe (return ()) signalBlock mconnidv + adjustmentSetUpper hadj upperx + adjustmentSetUpper vadj uppery + adjustmentSetLower hadj lowerx + adjustmentSetLower vadj lowery + adjustmentSetValue hadj valuex + adjustmentSetValue vadj valuey + adjustmentSetPageSize hadj pagex + adjustmentSetPageSize vadj pagey + maybe (return ()) signalUnblock mconnidh + maybe (return ()) signalUnblock mconnidv + + + diff --git a/src/Hoodle/ModelAction/Clipboard.hs b/src/Hoodle/ModelAction/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Clipboard.hs @@ -0,0 +1,65 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Clipboard +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +-- Clipboard io actions +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Clipboard where + +-- from other package +import Control.Lens +import Control.Monad.Trans +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Serialize as Se +import Graphics.UI.Gtk hiding (get,set) +-- from hoodle-platform +import Data.Hoodle.Simple +-- import Graphics.Hoodle.Render.Type +-- from this package +import Hoodle.ModelAction.Select +import Hoodle.Script.Hook +import Hoodle.Type.Event +import Hoodle.Type.HoodleState +-- + +-- | +updateClipboard :: HoodleState -> [Item] -> IO HoodleState +updateClipboard xstate itms + | null itms = return xstate + | otherwise = do + let ui = view gtkUIManager xstate + hdltag <- atomNew "hoodle" + -- tgttag <- atomNew "Stroke" + -- seltag <- atomNew "Stroke" + clipbd <- clipboardGet hdltag + let bstr = C8.unpack . B64.encode . Se.encode $ itms + clipboardSetText clipbd bstr + togglePaste ui True + case (view hookSet xstate) of + Nothing -> return () + Just hset -> case afterUpdateClipboardHook hset of + Nothing -> return () + Just uchook -> liftIO $ uchook itms + return xstate + + + +-- | +callback4Clip :: (MyEvent -> IO ()) -> Maybe String -> IO () +callback4Clip callbk Nothing = callbk (GotClipboardContent Nothing) +callback4Clip callbk (Just str) = do + let r = do let bstr = C8.pack str + bstr' <- B64.decode bstr + Se.decode bstr' + case r of + Left _err -> callbk (GotClipboardContent Nothing) + Right cnt -> callbk (GotClipboardContent (Just cnt)) diff --git a/src/Hoodle/ModelAction/Eraser.hs b/src/Hoodle/ModelAction/Eraser.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Eraser.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Eraser +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Eraser where + +import Control.Monad.State +-- from hoodle-platform +import Data.Hoodle.BBox +import Graphics.Hoodle.Render.Type.HitTest +import Graphics.Hoodle.Render.Util.HitTest + +-- | +eraseHitted :: (BBoxable a) => + AlterList (NotHitted a) (AlterList (NotHitted a) (Hitted a)) + -> State (Maybe BBox) [a] +eraseHitted Empty = error "something wrong in eraseHitted" +eraseHitted (n :-Empty) = return (unNotHitted n) +eraseHitted (n:-h:-rest) = do + mid <- elimHitted h + return . (unNotHitted n ++) . (mid ++) =<< eraseHitted rest diff --git a/src/Hoodle/ModelAction/File.hs b/src/Hoodle/ModelAction/File.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/File.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings, CPP, GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.File +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.File where + +-- from other package +import Control.Category +import Control.Lens +import Control.Monad +import Data.Attoparsec +import qualified Data.ByteString as B +import Data.Maybe +import Graphics.UI.Gtk hiding (get,set) +#ifdef POPPLER +import qualified Graphics.UI.Gtk.Poppler.Document as Poppler +import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage +#endif +import System.FilePath (takeExtension) +-- from hoodle-platform +import Data.Hoodle.Simple +import Graphics.Hoodle.Render +import qualified Text.Hoodle.Parse.Attoparsec as PA +import qualified Text.Xournal.Parse.Conduit as XP +import Text.Hoodle.Translate.FromXournal +-- from this package +import Hoodle.Type.HoodleState +-- +import Prelude hiding ((.),id) + +-- | get file content from xournal file and update xournal state + +getFileContent :: Maybe FilePath + -> HoodleState + -> IO HoodleState +getFileContent (Just fname) xstate = do + let ext = takeExtension fname + case ext of + ".hdl" -> do + bstr <- B.readFile fname + let r = parse PA.hoodle bstr + case r of + Done _ h -> constructNewHoodleStateFromHoodle h xstate + >>= return . set currFileName (Just fname) + _ -> print r >> return xstate + ".xoj" -> do + XP.parseXojFile fname >>= \x -> case x of + Left str -> do + putStrLn $ "file reading error : " ++ str + return xstate + Right xojcontent -> do + let hdlcontent = mkHoodleFromXournal xojcontent + nxstate <- constructNewHoodleStateFromHoodle hdlcontent xstate + return $ set currFileName (Just fname) nxstate + ".pdf" -> do + mhdl <- makeNewHoodleWithPDF fname + case mhdl of + Nothing -> getFileContent Nothing xstate + Just hdl -> do + newhdlstate <- constructNewHoodleStateFromHoodle hdl xstate + return . set currFileName Nothing $ newhdlstate + _ -> getFileContent Nothing xstate +getFileContent Nothing xstate = do + newhdl <- cnstrctRHoodle defaultHoodle + let newhdlstate = ViewAppendState newhdl + xstate' = set currFileName Nothing + . set hoodleModeState newhdlstate + $ xstate + return xstate' + + + + +-- | +constructNewHoodleStateFromHoodle :: Hoodle -> HoodleState -> IO HoodleState +constructNewHoodleStateFromHoodle hdl' xstate = do + hdl <- cnstrctRHoodle hdl' + let startinghoodleModeState = ViewAppendState hdl + return $ set hoodleModeState startinghoodleModeState xstate + +-- | +makeNewHoodleWithPDF :: FilePath -> IO (Maybe Hoodle) +makeNewHoodleWithPDF fp = do +#ifdef POPPLER + let fname = C.pack fp + mdoc <- popplerGetDocFromFile fname + case mdoc of + Nothing -> do + putStrLn $ "no such file " ++ fp + return Nothing + Just doc -> do + n <- Poppler.documentGetNPages doc + pg <- Poppler.documentGetPage doc 0 + (w,h) <- PopplerPage.pageGetSize pg + let dim = Dim w h + hdl = set title fname + . set pages (map (createPage dim fname) [1..n]) + $ emptyHoodle + return (Just hdl) +#else + error "makeNewHoodleWithPDF should not be used without poppler lib" +#endif + +-- | + +createPage :: Dimension -> B.ByteString -> Int -> Page +createPage dim fn n + | n == 1 = let bkg = BackgroundPdf "pdf" (Just "absolute") (Just fn ) n + in Page dim bkg [emptyLayer] + | otherwise = let bkg = BackgroundPdf "pdf" Nothing Nothing n + in Page dim bkg [emptyLayer] + +-- | + +toggleSave :: UIManager -> Bool -> IO () +toggleSave ui b = do + agr <- uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group?" + y:_ -> return y + Just savea <- actionGroupGetAction agr "SAVEA" + actionSetSensitive savea b diff --git a/src/Hoodle/ModelAction/Layer.hs b/src/Hoodle/ModelAction/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Layer.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Layer +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Layer where + +-- from other packages +import Control.Category +import Control.Compose +import Control.Lens +import Data.IORef +import Graphics.UI.Gtk hiding (get,set) +import qualified Graphics.UI.Gtk as Gtk (get) +-- from hoodle-platform +import Data.Hoodle.Generic +import Data.Hoodle.Zipper +import Graphics.Hoodle.Render.Type +-- +import Hoodle.Util +import Hoodle.Type.Alias +-- +import Prelude hiding ((.),id) + +-- | +getCurrentLayerOrSet :: Page EditMode -> (Maybe RLayer, Page EditMode) +getCurrentLayerOrSet pg = + let olayers = view glayers pg + nlayers = case olayers of + NoSelect _ -> selectFirst olayers + Select _ -> olayers + in case nlayers of + NoSelect _ -> (Nothing, set glayers nlayers pg) + Select osz -> (return . current =<< unO osz, set glayers nlayers pg) + +-- | +adjustCurrentLayer :: RLayer -> Page EditMode -> Page EditMode +adjustCurrentLayer nlayer pg = + let (molayer,pg') = getCurrentLayerOrSet pg + in maybe (set glayers (Select .O . Just . singletonSZ $ nlayer) pg') + (const $ let layerzipper = maybe (error "adjustCurrentLayer") id . unO . zipper . view glayers $ pg' + in set glayers (Select . O . Just . replace nlayer $ layerzipper) pg' ) + molayer + +-- | +layerChooseDialog :: IORef Int -> Int -> Int -> IO Dialog +layerChooseDialog layernumref cidx len = do + dialog <- dialogNew + layerentry <- entryNew + entrySetText layerentry (show (succ cidx)) + label <- labelNew (Just (" / " ++ show len)) + hbox <- hBoxNew False 0 + upper <- dialogGetUpper dialog + boxPackStart upper hbox PackNatural 0 + boxPackStart hbox layerentry PackNatural 0 + boxPackStart hbox label PackGrow 0 + widgetShowAll upper + buttonOk <- dialogAddButton dialog stockOk ResponseOk + _buttonCancel <- dialogAddButton dialog stockCancel ResponseCancel + + buttonOk `on` buttonActivated $ do + txt <- Gtk.get layerentry entryText + maybe (return ()) (modifyIORef layernumref . const . pred) . maybeRead $ txt + return dialog + + diff --git a/src/Hoodle/ModelAction/Page.hs b/src/Hoodle/ModelAction/Page.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Page.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Page +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Page where + +import Control.Applicative +import Control.Category +import Control.Lens +import Control.Monad (liftM) +import qualified Data.IntMap as M +import Data.Traversable (mapM) +import Graphics.UI.Gtk (adjustmentGetValue) +-- from hoodle-platform +import Data.Hoodle.Generic +import Data.Hoodle.Select +import Graphics.Hoodle.Render.Type +-- from this package +import Hoodle.Util +import Hoodle.Type.Alias +import Hoodle.Type.Canvas +import Hoodle.Type.Enum +import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement +import Hoodle.Type.Predefined +import Hoodle.View.Coordinate +-- +import Prelude hiding ((.),id,mapM) + + +-- | +getPageMap :: HoodleModeState -> M.IntMap (Page EditMode) +getPageMap = either (view gpages) (view gselAll) . hoodleModeStateEither + +-- | +setPageMap :: M.IntMap (Page EditMode) -> HoodleModeState -> HoodleModeState +setPageMap nmap = + either (ViewAppendState . set gpages nmap) + (SelectState . set gselSelected Nothing . set gselAll nmap ) + . hoodleModeStateEither + +-- | +updatePageAll :: HoodleModeState -> HoodleState -> IO HoodleState +updatePageAll hdlmodst xstate = do + let cmap = getCanvasInfoMap xstate + cmap' <- mapM (updatePage hdlmodst . adjustPage hdlmodst) cmap + return $ maybe xstate id + . setCanvasInfoMap cmap' + . set hoodleModeState hdlmodst $ xstate + +-- | +adjustPage :: HoodleModeState -> CanvasInfoBox -> CanvasInfoBox +adjustPage hdlmodst = selectBox fsingle fsingle + where fsingle :: CanvasInfo a -> CanvasInfo a + fsingle cinfo = let cpn = view currentPageNum cinfo + pagemap = getPageMap hdlmodst + in adjustwork cpn pagemap + where adjustwork cpn pagemap = + if M.notMember cpn pagemap + then let (minp,_) = M.findMin pagemap + (maxp,_) = M.findMax pagemap + in if cpn > maxp + then set currentPageNum maxp cinfo + else set currentPageNum minp cinfo + else cinfo + +-- | +getPageFromGHoodleMap :: Int -> GHoodle M.IntMap a -> a +getPageFromGHoodleMap pagenum = + maybeError ("getPageFromGHoodleMap " ++ show pagenum) . M.lookup pagenum . view gpages + + +-- | +updateCvsInfoFrmHoodle :: Hoodle EditMode -> CanvasInfoBox -> IO CanvasInfoBox +updateCvsInfoFrmHoodle hdl (CanvasSinglePage cinfo) = do + let pagenum = view currentPageNum cinfo + oarr = view (viewInfo.pageArrangement) cinfo + canvas = view drawArea cinfo + zmode = view (viewInfo.zoomMode) cinfo + geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas + let cdim = canvasDim geometry + pg = getPageFromGHoodleMap pagenum hdl + pdim = PageDimension $ view gdimension pg + (hadj,vadj) = view adjustments cinfo + (xpos,ypos) <- (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj + let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos) + vinfo = view viewInfo cinfo + nvinfo = xfrmViewInfo (const arr) vinfo + return + . CanvasSinglePage + . set currentPageNum pagenum + . xfrmCvsInfo (const nvinfo) $ cinfo + -- return . CanvasInfoBox + -- . set currentPageNum pagenum + -- . set (viewInfo.pageArrangement) arr $ cinfo +updateCvsInfoFrmHoodle hdl (CanvasContPage cinfo) = do + let pagenum = view currentPageNum cinfo + oarr = view (viewInfo.pageArrangement) cinfo + canvas = view drawArea cinfo + zmode = view (viewInfo.zoomMode) cinfo + (hadj,vadj) = view adjustments cinfo + (xdesk,ydesk) <- (,) <$> adjustmentGetValue hadj + <*> adjustmentGetValue vadj + geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas + let ulcoord = maybeError "updateCvsFromHoodle" $ + desktop2Page geometry (DeskCoord (xdesk,ydesk)) + let cdim = canvasDim geometry + let arr = makeContinuousArrangement zmode cdim hdl ulcoord + vinfo = view viewInfo cinfo + nvinfo = xfrmViewInfo (const arr) vinfo + return + . CanvasContPage + . set currentPageNum pagenum + . xfrmCvsInfo (const nvinfo) $ cinfo + +-- return . CanvasInfoBox +-- . set currentPageNum pagenum +-- . set (viewInfo.pageArrangement) arr $ cinfo +-- selectBoxAction fsingle fcont cinfobox +-- where fsingle cinfo = do + + +-- | +updatePage :: HoodleModeState -> CanvasInfoBox -> IO CanvasInfoBox +updatePage (ViewAppendState hdl) c = updateCvsInfoFrmHoodle hdl c +updatePage (SelectState thdl) c = do + let hdl = GHoodle (view gselTitle thdl) (view gselAll thdl) + updateCvsInfoFrmHoodle hdl c + +-- boxAction f cinfobox +-- where f :: (ViewMode a) => ViewModeSumType -> CanvasInfo a -> IO CanvasInfoBox +-- f mode cinfo = do +-- fcont _cinfo = do +-- let hdl = GHoodle (view gselTitle thdl) (view gselAll thdl) +-- updateCvsInfoFrmHoodle VMContPage hdl cinfobox + +-- | +setPage :: HoodleState -> PageNum -> CanvasId -> IO CanvasInfoBox +setPage xstate pnum cid = do + let cinfobox = getCanvasInfo cid xstate + selectBoxAction (liftM CanvasSinglePage . setPageSingle xstate pnum) + (liftM CanvasContPage . setPageCont xstate pnum) + cinfobox + +-- | setPageSingle : in Single Page mode +setPageSingle :: HoodleState -> PageNum + -> CanvasInfo SinglePage + -> IO (CanvasInfo SinglePage) +setPageSingle xstate pnum cinfo = do + let hdl = getHoodle xstate + geometry <- getCvsGeomFrmCvsInfo cinfo + let cdim = canvasDim geometry + let pg = getPageFromGHoodleMap (unPageNum pnum) hdl + pdim = PageDimension (view gdimension pg) + zmode = view (viewInfo.zoomMode) cinfo + arr = makeSingleArrangement zmode pdim cdim (0,0) + return $ set currentPageNum (unPageNum pnum) + . set (viewInfo.pageArrangement) arr $ cinfo + +-- | setPageCont : in Continuous Page mode +setPageCont :: HoodleState -> PageNum + -> CanvasInfo ContinuousPage + -> IO (CanvasInfo ContinuousPage) +setPageCont xstate pnum cinfo = do + let hdl = getHoodle xstate + geometry <- getCvsGeomFrmCvsInfo cinfo + let cdim = canvasDim geometry + zmode = view (viewInfo.zoomMode) cinfo + arr = makeContinuousArrangement zmode cdim hdl (pnum,PageCoord (0,0)) + return $ set currentPageNum (unPageNum pnum) + . set (viewInfo.pageArrangement) arr $ cinfo + +-- | +newSinglePageFromOld :: Page EditMode -> Page EditMode +newSinglePageFromOld = set glayers (fromList [emptyRLayer]) + + -- (NoSelect [emptyRLayer]) + + +-- | +addNewPageInHoodle :: AddDirection + -> Hoodle EditMode + -> Int + -> IO (Hoodle EditMode) +addNewPageInHoodle dir hdl cpn = do + let pagelst = M.elems . view gpages $ hdl + (pagesbefore,cpage:pagesafter) = splitAt cpn pagelst + npage = newSinglePageFromOld cpage + npagelst = case dir of + PageBefore -> pagesbefore ++ (npage : cpage : pagesafter) + PageAfter -> pagesbefore ++ (cpage : npage : pagesafter) + nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl + return nhdl + +-- | +relZoomRatio :: CanvasGeometry -> ZoomModeRel -> Double +relZoomRatio geometry rzmode = + let CvsCoord (cx0,_cy0) = desktop2Canvas geometry (DeskCoord (0,0)) + CvsCoord (cx1,_cy1) = desktop2Canvas geometry (DeskCoord (1,1)) + scalefactor = case rzmode of + ZoomIn -> predefinedZoomStepFactor + ZoomOut -> 1.0/predefinedZoomStepFactor + in (cx1-cx0) * scalefactor + diff --git a/src/Hoodle/ModelAction/Pen.hs b/src/Hoodle/ModelAction/Pen.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Pen.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Pen +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Pen where + +import Control.Category +import Control.Lens +import Data.Foldable +import qualified Data.IntMap as IM +import Data.Maybe +import qualified Data.Map as M +import Data.Sequence hiding (take, drop) +import Data.Strict.Tuple hiding (uncurry) +-- from hoodle-platform +import Data.Hoodle.BBox +import Data.Hoodle.Generic +import Data.Hoodle.Simple +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type +-- from this package +import Hoodle.ModelAction.Layer +import Hoodle.ModelAction.Page +import Hoodle.Type.Canvas +import Hoodle.Type.Enum +import Hoodle.Type.PageArrangement +-- +import Prelude hiding ((.), id) + +-- | +addPDraw :: PenInfo + -> RHoodle + -> PageNum + -> Seq (Double,Double,Double) + -> IO (RHoodle,BBox) + -- ^ new hoodle and bbox in page coordinate +addPDraw pinfo hdl (PageNum pgnum) pdraw = do + let ptype = view penType pinfo + pcolor = view (currentTool.penColor) pinfo + pcolname = fromJust (M.lookup pcolor penColorNameMap) + pwidth = view (currentTool.penWidth) pinfo + pvwpen = view variableWidthPen pinfo + (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl) + currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer + ptool = case ptype of + PenWork -> "pen" + HighlighterWork -> "highlighter" + _ -> error "error in addPDraw" + newstroke = + case pvwpen of + False -> Stroke { stroke_tool = ptool + , stroke_color = pcolname + , stroke_width = pwidth + , stroke_data = map (\(x,y,_)->x:!:y) . toList $ pdraw + } + True -> VWStroke { stroke_tool = ptool + , stroke_color = pcolname + , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw + } + + newstrokebbox = mkStrokeBBox newstroke + bbox = strkbbx_bbx newstrokebbox + newlayerbbox <- updateLayerBuf (Just bbox) + . over gitems (++[RItemStroke newstrokebbox]) + $ currlayer + + let newpagebbox = adjustCurrentLayer newlayerbbox currpage + newhdlbbox = set gpages (IM.adjust (const newpagebbox) pgnum (view gpages hdl) ) hdl + return (newhdlbbox,bbox) + diff --git a/src/Hoodle/ModelAction/Select.hs b/src/Hoodle/ModelAction/Select.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Select.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Select +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Select where + +-- from other package +import Control.Category +import Control.Lens +import Control.Monad +import Data.Algorithm.Diff +import Data.Foldable (foldl') +import qualified Data.IntMap as M +import qualified Data.Map as Map +import Data.Monoid +import Data.Sequence (ViewL(..),viewl,Seq) +import Data.Strict.Tuple +import Data.Time.Clock +import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Matrix ( invert, transformPoint ) +import Graphics.UI.Gtk hiding (get,set) +-- from hoodle-platform +import Data.Hoodle.Generic +import Data.Hoodle.BBox +import Data.Hoodle.Select +import Data.Hoodle.Simple hiding (Page,Hoodle) +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest +import Graphics.Hoodle.Render.Util +import Graphics.Hoodle.Render.Util.HitTest +-- from this package +import Hoodle.ModelAction.Layer +import Hoodle.Type.Enum +import Hoodle.Type.Alias +import Hoodle.Type.Predefined +import Hoodle.Type.PageArrangement +import Hoodle.Util +import Hoodle.View.Coordinate +-- +import Prelude hiding ((.),id) + + +-- | +data Handle = HandleTL + | HandleTR + | HandleBL + | HandleBR + | HandleTM + | HandleBM + | HandleML + | HandleMR + deriving (Show) + +-- | +scaleFromToBBox :: BBox -> BBox -> (Double,Double) -> (Double,Double) +scaleFromToBBox (BBox (ox1,oy1) (ox2,oy2)) (BBox (nx1,ny1) (nx2,ny2)) (x,y) = + let scalex = (nx2-nx1) / (ox2-ox1) + scaley = (ny2-ny1) / (oy2-oy1) + nx = (x-ox1)*scalex+nx1 + ny = (y-oy1)*scaley+ny1 + in (nx,ny) + +-- | +isBBoxDeltaSmallerThan :: Double -> PageNum -> CanvasGeometry -> BBox -> BBox -> Bool +isBBoxDeltaSmallerThan delta pnum geometry + (BBox (x11,y11) (x12,y12)) (BBox (x21,y21) (x22,y22)) = + let (x11',y11') = coordtrans (x11,y11) + (x12',y12') = coordtrans (x12,y12) + (x21',y21') = coordtrans (x21,y21) + (x22',y22') = coordtrans (x22,y22) + in (x11'-x21' > (-delta) && x11'-x21' < delta) + && (y11'-y21' > (-delta) && y11'-y21' < delta) + && (x12'-x22' > (-delta) && x12'-x22' < delta) + && (y11'-y21' > (-delta) && y12'-y22' < delta) + where coordtrans (x,y) = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry + $ (pnum,PageCoord (x,y)) + +-- | +changeItemBy :: ((Double,Double)->(Double,Double)) -> RItem -> RItem +changeItemBy func (RItemStroke strk) = RItemStroke (changeStrokeBy func strk) +changeItemBy func (RItemImage img sfc) = RItemImage (changeImageBy func img) sfc + + + +-- | modify stroke using a function +changeStrokeBy :: ((Double,Double)->(Double,Double)) -> StrokeBBox -> StrokeBBox +changeStrokeBy func (StrokeBBox (Stroke t c w ds) _bbox) = + let change ( x :!: y ) = let (nx,ny) = func (x,y) + in nx :!: ny + newds = map change ds + nstrk = Stroke t c w newds + nbbox = bboxFromStroke nstrk + in StrokeBBox nstrk nbbox +changeStrokeBy func (StrokeBBox (VWStroke t c ds) _bbox) = + let change (x,y,z) = let (nx,ny) = func (x,y) + in (nx,ny,z) + newds = map change ds + nstrk = VWStroke t c newds + nbbox = bboxFromStroke nstrk + in StrokeBBox nstrk nbbox + +-- | +changeImageBy :: ((Double,Double)->(Double,Double)) -> ImageBBox -> ImageBBox +changeImageBy func (ImageBBox (Image bstr (x,y) (Dim w h)) _bbox) = + let (x1,y1) = func (x,y) + (x2,y2) = func (x+w,y+h) + nimg = Image bstr (x1,y1) (Dim (x2-x1) (y2-y1)) + in mkImageBBox nimg + +-- nbbox = bboxFromImage nimg +-- in ImageBBox nimg nbbox + +-- | +rItmsInActiveLyr :: Page SelectMode -> Either [RItem] (TAlterHitted RItem) +rItmsInActiveLyr = unTEitherAlterHitted.view (glayers.selectedLayer.gitems) + +-- | +getSelectedItms :: Page SelectMode -> [RItem] +getSelectedItms = either (const []) (concatMap unHitted . getB) . rItmsInActiveLyr + +-- | start a select mode with alter list selection +makePageSelectMode :: Page EditMode -- ^ base page + -> TAlterHitted RItem -- ^ current selection layer (active layer will be replaced) + -> Page SelectMode -- ^ resultant select mode page +makePageSelectMode page alist = + let (mcurrlayer,npage) = getCurrentLayerOrSet page + clyr = maybeError "makePageSelectMode" mcurrlayer + nlyr= GLayer (view gbuffer clyr) (TEitherAlterHitted (Right alist)) + -- tpg = mkHPage npage + -- npg = set (glayers.selectedLayer) nlyr tpg + in set (glayers.selectedLayer) nlyr (mkHPage npage) + + +-- | get unselected part of page and make an ordinary page +deleteSelected :: Page SelectMode -> Page SelectMode +deleteSelected tpage = + let activelayer = rItmsInActiveLyr tpage + buf = view (glayers.selectedLayer.gbuffer) tpage + in case activelayer of + Left _ -> tpage + Right alist -> + let leftstrs = concat (getA alist) + layer' = GLayer buf . TEitherAlterHitted . Left $ leftstrs + in set (glayers.selectedLayer) layer' tpage + + +-- | modify the whole selection using a function +changeSelectionBy :: ((Double,Double) -> (Double,Double)) + -> Page SelectMode -> Page SelectMode +changeSelectionBy func tpage = + let activelayer = rItmsInActiveLyr tpage + buf = view (glayers.selectedLayer.gbuffer) tpage + in case activelayer of + Left _ -> tpage + Right alist -> + let alist' =fmapAL id + (Hitted . map (changeItemBy func) . unHitted) + alist + layer' = GLayer buf . TEitherAlterHitted . Right $ alist' + in set (glayers.selectedLayer) layer' tpage + + + +-- | special case of offset modification +changeSelectionByOffset :: (Double,Double) -> Page SelectMode -> Page SelectMode +changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy)) + +-- | +offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) +offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy) + + +-- | +updateTempHoodleSelect :: Hoodle SelectMode -> Page SelectMode -> Int + -> Hoodle SelectMode +updateTempHoodleSelect thdl tpage pagenum = + let pgs = view gselAll thdl + pgs' = M.adjust (const (hPage2RPage tpage)) pagenum pgs + in set gselAll pgs' + . set gselSelected (Just (pagenum,tpage)) + $ thdl + +-- | +updateTempHoodleSelectIO :: Hoodle SelectMode -> Page SelectMode -> Int + -> IO (Hoodle SelectMode) +updateTempHoodleSelectIO thdl tpage pagenum = do + let pgs = view gselAll thdl + newpage <- (updatePageBuf.hPage2RPage) tpage + let pgs' = M.adjust (const newpage) pagenum pgs + return $ set gselAll pgs' + . set gselSelected (Just (pagenum,tpage)) + $ thdl + +-- | +calculateWholeBBox :: [StrokeBBox] -> Maybe BBox +calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. strkbbx_bbx ) + +-- | +hitInSelection :: Page SelectMode -> (Double,Double) -> Bool +hitInSelection tpage point = + case rItmsInActiveLyr tpage of + Left _ -> False + Right alist -> + let Union bboxall = mconcat + . map ( Union . Middle. getBBox ) + . takeHitted $ alist + in case bboxall of + Middle bbox -> isPointInBBox bbox point + _ -> False + +-- | +getULBBoxFromSelected :: Page SelectMode -> ULMaybe BBox +getULBBoxFromSelected tpage = + case rItmsInActiveLyr tpage of + Left _ -> Bottom + Right alist -> bbox4All . takeHitted $ alist + +-- | +hitInHandle :: Page SelectMode -> (Double,Double) -> Bool +hitInHandle tpage point = + case getULBBoxFromSelected tpage of + Middle bbox -> maybe False (const True) (checkIfHandleGrasped bbox point) + _ -> False + + +-- | +toggleCutCopyDelete :: UIManager -> Bool -> IO () +toggleCutCopyDelete ui b = do + agr <- uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group?" + y:_ -> return y + Just deletea <- actionGroupGetAction agr "DELETEA" + Just copya <- actionGroupGetAction agr "COPYA" + Just cuta <- actionGroupGetAction agr "CUTA" + let copycutdeletea = [copya,cuta,deletea] + mapM_ (flip actionSetSensitive b) copycutdeletea + +-- | +togglePaste :: UIManager -> Bool -> IO () +togglePaste ui b = do + agr <- uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group?" + y:_ -> return y + Just pastea <- actionGroupGetAction agr "PASTEA" + actionSetSensitive pastea b + +-- | +changeStrokeColor :: PenColor -> StrokeBBox -> StrokeBBox +changeStrokeColor pcolor str = + let Just cname = Map.lookup pcolor penColorNameMap + strsmpl = strkbbx_strk str + in str { strkbbx_strk = set color cname strsmpl } + +-- | +changeStrokeWidth :: Double -> StrokeBBox -> StrokeBBox +changeStrokeWidth pwidth str = + let nstrsmpl = case strkbbx_strk str of + Stroke t c _w d -> Stroke t c pwidth d + VWStroke t c d -> Stroke t c pwidth (map (\(x,y,_z) -> (x:!:y)) d) + -- Img b w h -> Img b w h + in str { strkbbx_strk = nstrsmpl } + +-- | +changeItemStrokeWidth :: Double -> RItem -> RItem +changeItemStrokeWidth pwidth (RItemStroke strk) = RItemStroke (changeStrokeWidth pwidth strk) +changeItemStrokeWidth _ r = r + +-- | +changeItemStrokeColor :: PenColor -> RItem -> RItem +changeItemStrokeColor pcolor (RItemStroke strk) = RItemStroke (changeStrokeColor pcolor strk) +changeItemStrokeColor _ r = r + + + +-- | +newtype CmpBBox a = CmpBBox { unCmpBBox :: a } + -- deriving Show +instance (BBoxable a) => Eq (CmpBBox a) where + CmpBBox s1 == CmpBBox s2 = getBBox s1 == getBBox s2 + +-- | +isSame :: DI -> Bool +isSame B = True +isSame _ = False + +-- | +separateFS :: [(DI,a)] -> ([a],[a]) +separateFS = foldr f ([],[]) + where f (F,x) (fs,ss) = (x:fs,ss) + f (S,x) (fs,ss) = (fs,x:ss) + f (B,_x) (fs,ss) = (fs,ss) + +-- | +getDiffBBox :: (BBoxable a) => [a] -> [a] -> [(DI,a)] +getDiffBBox lst1 lst2 = + let nlst1 = fmap CmpBBox lst1 + nlst2 = fmap CmpBBox lst2 + diffresult = getDiff nlst1 nlst2 + in map (\(x,y)->(x,unCmpBBox y)) diffresult + +-- | +checkIfHandleGrasped :: BBox -> (Double,Double) -> Maybe Handle +checkIfHandleGrasped (BBox (ulx,uly) (lrx,lry)) (x,y) + | isPointInBBox (BBox (ulx-5,uly-5) (ulx+5,uly+5)) (x,y) = Just HandleTL + | isPointInBBox (BBox (lrx-5,uly-5) (lrx+5,uly+5)) (x,y) = Just HandleTR + | isPointInBBox (BBox (ulx-5,lry-5) (ulx+5,lry+5)) (x,y) = Just HandleBL + | isPointInBBox (BBox (lrx-5,lry-5) (lrx+5,lry+5)) (x,y) = Just HandleBR + | isPointInBBox (BBox (0.5*(ulx+lrx)-5,uly-5) (0.5*(ulx+lrx)+5,uly+5)) (x,y) = Just HandleTM + | isPointInBBox (BBox (0.5*(ulx+lrx)-5,lry-5) (0.5*(ulx+lrx)+5,lry+5)) (x,y) = Just HandleBM + | isPointInBBox (BBox (ulx-5,0.5*(uly+lry)-5) (ulx+5,0.5*(uly+lry)+5)) (x,y) = Just HandleML + | isPointInBBox (BBox (lrx-5,0.5*(uly+lry)-5) (lrx+5,0.5*(uly+lry)+5)) (x,y) = Just HandleMR + | otherwise = Nothing + +getNewBBoxFromHandlePos :: Handle -> BBox -> (Double,Double) -> BBox +getNewBBoxFromHandlePos handle (BBox (ox1,oy1) (ox2,oy2)) (x,y) = + case handle of + HandleTL -> BBox (x,y) (ox2,oy2) + HandleTR -> BBox (ox1,y) (x,oy2) + HandleBL -> BBox (x,oy1) (ox2,y) + HandleBR -> BBox (ox1,oy1) (x,y) + HandleTM -> BBox (ox1,y) (ox2,oy2) + HandleBM -> BBox (ox1,oy1) (ox2,y) + HandleML -> BBox (x,oy1) (ox2,oy2) + HandleMR -> BBox (ox1,oy1) (x,oy2) + + +angleBAC :: (Double,Double) -> (Double,Double) -> (Double,Double) -> Double +angleBAC (bx,by) (ax,ay) (cx,cy) = + let theta1 | ax==bx && ay>by = pi/2.0 + | ax==bx && ay<=by = -pi/2.0 + | axby = atan ((ay-by)/(ax-bx)) + pi + | axby = pi/2.0 + | cx==bx && cy<=by = -pi/2.0 + | cxby = atan ((cy-by)/(cx-bx)) +pi + | cx pi = dtheta - 2.0*pi + | dtheta < (-pi) = dtheta + 2.0*pi + | otherwise = dtheta + in result + + +wrappingAngle :: Seq (Double,Double) -> (Double,Double) -> Double +wrappingAngle lst p = + case viewl lst of + EmptyL -> 0 + x :< xs -> Prelude.snd $ foldl' f (x,0) xs + where f (q',theta) q = let theta' = angleBAC p q' q + in theta' `seq` (q,theta'+theta) + +mappingDegree :: Seq (Double,Double) -> (Double,Double) -> Int +mappingDegree lst = round . (/(2.0*pi)) . wrappingAngle lst + +-- | +hitLassoPoint :: Seq (Double,Double) -> (Double,Double) -> Bool +hitLassoPoint lst = odd . mappingDegree lst + +-- | +hitLassoStroke :: Seq (Double,Double) -> StrokeBBox -> Bool +hitLassoStroke lst = all (hitLassoPoint lst) . getXYtuples . strkbbx_strk + +-- | +hitLassoItem :: Seq (Double,Double) -> RItem -> Bool +hitLassoItem lst (RItemStroke strk) = hitLassoStroke lst strk +hitLassoItem lst (RItemImage img _) = + hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) + && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) + where BBox (x1,y1) (x2,y2) = getBBox img + + +data TempSelectRender a = TempSelectRender { tempSurface :: Surface + , widthHeight :: (Double,Double) + , tempSelectInfo :: a + } + +type TempSelection = TempSelectRender [RItem] + +data ItmsNImg = ItmsNImg { itmNimg_itms :: [RItem] + , itmNimg_mbbx :: Maybe BBox + , imageSurface :: Surface } + + +-- | +mkItmsNImg :: CanvasGeometry -> Page SelectMode -> IO ItmsNImg +mkItmsNImg _geometry tpage = do + let itms = getSelectedItms tpage + drawselection = mapM_ (renderItem.rItem2Item) itms + Dim cw ch = view gdimension tpage + mbbox = case getULBBoxFromSelected tpage of + Middle bbox -> Just bbox + _ -> Nothing + sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch) + renderWith sfc $ do + setSourceRGBA 1 1 1 0 + rectangle 0 0 cw ch + fill + setSourceRGBA 0 0 0 1 + drawselection + return $ ItmsNImg itms mbbox sfc + +-- | +drawTempSelectImage :: CanvasGeometry + -> TempSelectRender ItmsNImg + -> Matrix -- ^ transformation matrix + -> Render () +drawTempSelectImage geometry tempselection xformmat = do + let sfc = imageSurface (tempSelectInfo tempselection) + CanvasDimension (Dim cw ch) = canvasDim geometry + invxformmat = invert xformmat + newvbbox = BBox (transformPoint invxformmat (0,0)) + (transformPoint invxformmat (cw,ch)) + mbbox = itmNimg_mbbx (tempSelectInfo tempselection) + newmbbox = case unIntersect (Intersect (Middle newvbbox) `mappend` fromMaybe mbbox) of + Middle bbox -> Just bbox + _ -> Just newvbbox + setMatrix xformmat + clipBBox newmbbox + setSourceSurface sfc 0 0 + setOperator OperatorOver + paint + + + +-- | +tempSelected :: TempSelection -> [RItem] +tempSelected = tempSelectInfo + +mkTempSelection :: Surface -> (Double,Double) -> [RItem] -> TempSelection +mkTempSelection sfc (w,h) = TempSelectRender sfc (w,h) + +-- | update the content of temp selection. should not be often updated +updateTempSelection :: TempSelectRender a -> Render () -> Bool -> IO () +updateTempSelection tempselection renderfunc isFullErase = + renderWith (tempSurface tempselection) $ do + when isFullErase $ do + let (cw,ch) = widthHeight tempselection + setSourceRGBA 0.5 0.5 0.5 1 + rectangle 0 0 cw ch + fill + renderfunc + +-- | +getNewCoordTime :: ((Double,Double),UTCTime) + -> (Double,Double) + -> IO (Bool,((Double,Double),UTCTime)) +getNewCoordTime (prev,otime) (x,y) = do + ntime <- getCurrentTime + let dtime = diffUTCTime ntime otime + willUpdate = dtime > dtime_bound + (nprev,nntime) = if dtime > dtime_bound + then ((x,y),ntime) + else (prev,otime) + return (willUpdate,(nprev,nntime)) + +-- | +adjustItemPosition4Paste :: CanvasGeometry -> PageNum -> [RItem] -> [RItem] +adjustItemPosition4Paste geometry pgn itms = + case bbox of + Middle (BBox (xs0,ys0) _) -> fmap (changeItemBy (offsetFunc (x0-xs0,y0-ys0))) itms + _ -> itms + where bbox = bbox4All itms + ViewPortBBox (BBox (xv0,yv0) _) = canvasViewPort geometry + (x0,y0) = maybe (0,0) + (\(pgn',norigin) -> if pgn == pgn' then unPageCoord norigin else (0,0)) + $ desktop2Page geometry (DeskCoord (xv0,yv0)) + diff --git a/src/Hoodle/ModelAction/Window.hs b/src/Hoodle/ModelAction/Window.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Window.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.Window +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Window where + +-- from other packages +import Control.Category +import Control.Lens +import Control.Monad.Trans +import qualified Data.IntMap as M +import Graphics.UI.Gtk hiding (get,set) +import qualified Graphics.UI.Gtk as Gtk (set) +import System.FilePath +-- from this package +import Hoodle.Device +import Hoodle.Type.Canvas +import Hoodle.Type.Event +import Hoodle.Type.PageArrangement +import Hoodle.Type.Window +import Hoodle.Type.HoodleState +import Hoodle.Util +-- +import Prelude hiding ((.),id) + + + +-- | set frame title according to file name + +setTitleFromFileName :: HoodleState -> IO () +setTitleFromFileName xstate = do + case view currFileName xstate of + Nothing -> Gtk.set (view rootOfRootWindow xstate) + [ windowTitle := "untitled" ] + Just filename -> Gtk.set (view rootOfRootWindow xstate) + [ windowTitle := takeFileName filename] + +-- | + +newCanvasId :: CanvasInfoMap -> CanvasId +newCanvasId cmap = + let cids = M.keys cmap + in (maximum cids) + 1 + +-- | initialize CanvasInfo with creating windows and connect events + +initCanvasInfo :: ViewMode a => HoodleState -> CanvasId -> IO (CanvasInfo a) +initCanvasInfo xstate cid = + minimalCanvasInfo xstate cid >>= connectDefaultEventCanvasInfo xstate + + +-- | only creating windows + +minimalCanvasInfo :: ViewMode a => HoodleState -> CanvasId -> IO (CanvasInfo a) +minimalCanvasInfo _xstate cid = do + canvas <- drawingAreaNew + scrwin <- scrolledWindowNew Nothing Nothing + containerAdd scrwin canvas + hadj <- adjustmentNew 0 0 500 100 200 200 + vadj <- adjustmentNew 0 0 500 100 200 200 + scrolledWindowSetHAdjustment scrwin hadj + scrolledWindowSetVAdjustment scrwin vadj + -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic + return $ CanvasInfo cid canvas scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing + + +-- | only connect events + +connectDefaultEventCanvasInfo :: ViewMode a => + HoodleState -> CanvasInfo a -> IO (CanvasInfo a ) +connectDefaultEventCanvasInfo xstate cinfo = do + let callback = view callBack xstate + dev = view deviceList xstate + canvas = _drawArea cinfo + cid = _canvasId cinfo + scrwin = _scrolledWindow cinfo + hadj = _horizAdjustment cinfo + vadj = _vertAdjustment cinfo + + _sizereq <- canvas `on` sizeRequest $ return (Requisition 800 400) + + _bpevent <- canvas `on` buttonPressEvent $ tryEvent $ do + (mbtn,p) <- getPointer dev + let pbtn = maybe PenButton1 id mbtn + liftIO (callback (PenDown cid pbtn p)) + _confevent <- canvas `on` configureEvent $ tryEvent $ do + (w,h) <- eventSize + liftIO $ callback + (CanvasConfigure cid (fromIntegral w) (fromIntegral h)) + _brevent <- canvas `on` buttonReleaseEvent $ tryEvent $ do + (_,p) <- getPointer dev + liftIO (callback (PenUp cid p)) + _exposeev <- canvas `on` exposeEvent $ tryEvent $ do + liftIO $ callback (UpdateCanvas cid) + + {- + canvas `on` enterNotifyEvent $ tryEvent $ do + win <- liftIO $ widgetGetDrawWindow canvas + liftIO $ drawWindowSetCursor win (Just cursorDot) + return () + -} + widgetAddEvents canvas [PointerMotionMask,Button1MotionMask] + let ui = view gtkUIManager xstate + 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) ) + b <- liftIO $ toggleActionGetActive uxinputa + if b then widgetSetExtensionEvents canvas [ExtensionEventsAll] + else widgetSetExtensionEvents canvas [ExtensionEventsNone] + hadjconnid <- afterValueChanged hadj $ do + v <- adjustmentGetValue hadj + callback (HScrollBarMoved cid v) + vadjconnid <- afterValueChanged vadj $ do + v <- adjustmentGetValue vadj + callback (VScrollBarMoved cid v) + Just vscrbar <- scrolledWindowGetVScrollbar scrwin + _bpevtvscrbar <- vscrbar `on` buttonPressEvent $ do + v <- liftIO $ adjustmentGetValue vadj + liftIO (callback (VScrollBarStart cid v)) + return False + _brevtvscrbar <- vscrbar `on` buttonReleaseEvent $ do + v <- liftIO $ adjustmentGetValue vadj + liftIO (callback (VScrollBarEnd cid v)) + return False + return $ cinfo { _horizAdjConnId = Just hadjconnid + , _vertAdjConnId = Just vadjconnid } + +-- | recreate windows from old canvas info but no event connect + +reinitCanvasInfoStage1 :: (ViewMode a) => + HoodleState + -> CanvasInfo a -> IO (CanvasInfo a) +reinitCanvasInfoStage1 xstate oldcinfo = do + let cid = view canvasId oldcinfo + newcinfo <- minimalCanvasInfo xstate cid + return $ newcinfo { _viewInfo = _viewInfo oldcinfo + , _currentPageNum = _currentPageNum oldcinfo + } + + +-- | event connect + +reinitCanvasInfoStage2 :: (ViewMode a) => + HoodleState -> CanvasInfo a -> IO (CanvasInfo a) +reinitCanvasInfoStage2 = connectDefaultEventCanvasInfo + +-- | event connecting for all windows + +eventConnect :: HoodleState -> WindowConfig + -> IO (HoodleState,WindowConfig) +eventConnect xstate (Node cid) = do + let cmap = getCanvasInfoMap xstate + cinfobox = maybeError "eventConnect" $ M.lookup cid cmap + ncinfobox <- insideAction4CvsInfoBoxF (reinitCanvasInfoStage2 xstate) cinfobox + let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate + return (xstate', Node cid) +eventConnect xstate (HSplit wconf1 wconf2) = do + (xstate',wconf1') <- eventConnect xstate wconf1 + (xstate'',wconf2') <- eventConnect xstate' wconf2 + return (xstate'',HSplit wconf1' wconf2') +eventConnect xstate (VSplit wconf1 wconf2) = do + (xstate',wconf1') <- eventConnect xstate wconf1 + (xstate'',wconf2') <- eventConnect xstate' wconf2 + return (xstate'',VSplit wconf1' wconf2') + +{- case cinfobox of + CanvasInfoBox cinfo -> do + ncinfo <- reinitCanvasInfoStage2 xstate cinfo + let xstate' = updateFromCanvasInfoAsCurrentCanvas (CanvasInfoBox ncinfo) xstate -} + + + +-- | default construct frame + +constructFrame :: HoodleState -> WindowConfig + -> IO (HoodleState,Widget,WindowConfig) +constructFrame hst wcfg = do + putStrLn "in constructFrame" + constructFrame' (CanvasSinglePage defaultCvsInfoSinglePage) hst wcfg + + + +-- | construct frames with template + +constructFrame' :: CanvasInfoBox -> + HoodleState -> WindowConfig + -> IO (HoodleState,Widget,WindowConfig) +constructFrame' template oxstate (Node cid) = do + let ocmap = getCanvasInfoMap oxstate + + + (cinfobox,_cmap,xstate) <- case M.lookup cid ocmap of + Just cinfobox' -> return (cinfobox',ocmap,oxstate) + Nothing -> do + let cinfobox' = setCanvasId cid template + cmap' = M.insert cid cinfobox' ocmap + xstate' = maybe oxstate id (setCanvasInfoMap cmap' oxstate) + return (cinfobox',cmap',xstate') + ncinfobox <- insideAction4CvsInfoBoxF (reinitCanvasInfoStage1 xstate) cinfobox + let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate + let scrwin = fmap4CvsInfoBox (castToWidget.view scrolledWindow) ncinfobox + return (xstate', scrwin, Node cid) +constructFrame' template xstate (HSplit wconf1 wconf2) = do + (xstate',win1,wconf1') <- constructFrame' template xstate wconf1 + (xstate'',win2,wconf2') <- constructFrame' template xstate' wconf2 + let callback = view callBack xstate'' + hpane' <- hPanedNew + hpane' `on` buttonPressEvent $ do + liftIO (callback PaneMoveStart) + return False + hpane' `on` buttonReleaseEvent $ do + liftIO (callback PaneMoveEnd) + return False + panedPack1 hpane' win1 True False + panedPack2 hpane' win2 True False + widgetShowAll hpane' + return (xstate'',castToWidget hpane', HSplit wconf1' wconf2') +constructFrame' template xstate (VSplit wconf1 wconf2) = do + (xstate',win1,wconf1') <- constructFrame' template xstate wconf1 + (xstate'',win2,wconf2') <- constructFrame' template xstate' wconf2 + let callback = view callBack xstate'' + vpane' <- vPanedNew + vpane' `on` buttonPressEvent $ do + liftIO (callback PaneMoveStart) + return False + vpane' `on` buttonReleaseEvent $ do + liftIO (callback PaneMoveEnd) + return False + panedPack1 vpane' win1 True False + panedPack2 vpane' win2 True False + widgetShowAll vpane' + return (xstate'',castToWidget vpane', VSplit wconf1' wconf2') + + + +{- case cinfobox of + CanvasInfoBox cinfo -> do + ncinfo <- reinitCanvasInfoStage1 xstate cinfo + let xstate' = updateFromCanvasInfoAsCurrentCanvas (CanvasInfoBox ncinfo) xstate -} diff --git a/src/Hoodle/Script.hs b/src/Hoodle/Script.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Script.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Script +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Script where + +import Hoodle.Script.Hook +import Config.Dyre.Relaunch + +-- | + +data ScriptConfig = ScriptConfig { message :: Maybe String + , hook :: Maybe Hook + , errorMsg :: Maybe String + } + +-- | + +defaultScriptConfig :: ScriptConfig +defaultScriptConfig = ScriptConfig Nothing Nothing Nothing + +-- | + +showError :: ScriptConfig -> String -> ScriptConfig +showError cfg msg = cfg { errorMsg = Just msg } + + +-- | + +relaunchApplication :: IO () +relaunchApplication = do + putStrLn "relaunching hoodle!" + relaunchMaster Nothing + + diff --git a/src/Hoodle/Script/Coroutine.hs b/src/Hoodle/Script/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Script/Coroutine.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Script.Coroutine +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Script.Coroutine where + +import Control.Lens +import Control.Monad.State +-- from hoodle-platform +import Data.Hoodle.Simple +-- from this package +import qualified Hoodle.Script.Hook as H +import Hoodle.Type.Coroutine +import Hoodle.Type.HoodleState +-- +import Prelude hiding ((.),id) + +-- | + +afterSaveHook :: Hoodle -> MainCoroutine () +afterSaveHook hdl = do + xstate <- get + let aftersavehk = do + hset <- view hookSet xstate + H.afterSaveHook hset + maybe (return ()) (\f -> liftIO (f hdl)) aftersavehk + +-- | + +saveAsHook :: Hoodle -> MainCoroutine () +saveAsHook hdl = do + xstate <- get + let saveashk = do + hset <- view hookSet xstate + H.saveAsHook hset + maybe (return ()) (\f -> liftIO (f hdl)) saveashk + + diff --git a/src/Hoodle/Script/Hook.hs b/src/Hoodle/Script/Hook.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Script/Hook.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Script.Hook +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Script.Hook where + +import Data.Hoodle.Simple + +-- | +data Hook = Hook { saveAsHook :: Maybe (Hoodle -> IO ()) + , afterSaveHook :: Maybe (Hoodle -> IO ()) + , afterUpdateClipboardHook :: Maybe ([Item] -> IO ()) + } + + diff --git a/src/Hoodle/Type.hs b/src/Hoodle/Type.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type +( module Hoodle.Type.Canvas +, module Hoodle.Type.Coroutine +, module Hoodle.Type.Enum +, module Hoodle.Type.Event +, module Hoodle.Type.HoodleState +) where + +import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine +import Hoodle.Type.Enum +import Hoodle.Type.Event +import Hoodle.Type.HoodleState diff --git a/src/Hoodle/Type/Alias.hs b/src/Hoodle/Type/Alias.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Alias.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE EmptyDataDecls, TypeFamilies, RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Alias +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +---------------------------------------------------------------------------- + +module Hoodle.Type.Alias where + +-- from hoodle-platform +import Graphics.Hoodle.Render.Type + +-- | +data EditMode = EditMode + +-- | +data SelectMode = SelectMode + +type family Hoodle a :: * +type family Page a :: * +type family Layer a :: * + + +-- type instance Layer EditMode = RLayer +-- type instance Layer SelectMode = HLayers + +type instance Page EditMode = RPage +type instance Page SelectMode = HPage + + +type instance Hoodle EditMode = RHoodle +type instance Hoodle SelectMode = HHoodle + + diff --git a/src/Hoodle/Type/Canvas.hs b/src/Hoodle/Type/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Canvas.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, ExistentialQuantification, + Rank2Types, GADTs, RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Canvas +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.Canvas +( +-- * data types + CanvasId +, PenDraw (..) +, emptyPenDraw +, ViewInfo (..) +, CanvasInfo (..) +, CanvasInfoBox (..) +, CanvasInfoMap +-- , PenType (..) +, WidthColorStyle +, PenHighlighterEraserSet +, PenInfo +-- * default constructor +, defaultViewInfoSinglePage +, defaultCvsInfoSinglePage +, defaultPenWCS +, defaultEraserWCS +, defaultTextWCS +, defaultHighligherWCS +, defaultPenInfo +-- * lenses +, points +, zoomMode +, pageArrangement +, canvasId +, drawArea +, scrolledWindow +, viewInfo +, currentPageNum +-- , currentPage +, horizAdjustment +, vertAdjustment +, horizAdjConnId +, vertAdjConnId +, adjustments +, currentTool +, penWidth +, penColor +, currPen +, currHighlighter +, currEraser +, currText +, penType +, penSet +, variableWidthPen +-- * for box +, xfrmCvsInfo +, xfrmViewInfo +, getDrawAreaFromBox +, unboxGet +, fmap4CvsInfoBox +, insideAction4CvsInfoBox +, insideAction4CvsInfoBoxF +, boxAction +, selectBoxAction +, selectBox +-- , pageArrEitherFromCanvasInfoBox +-- , viewModeBranch +-- * others +-- , getPage +, updateCanvasDimForSingle +, updateCanvasDimForContSingle +) where + +import Control.Applicative ((<*>),(<$>)) +import Control.Category +import Control.Lens +import qualified Data.IntMap as M +import Data.Sequence +import Graphics.UI.Gtk hiding (get,set) +-- +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.BBox +import Data.Hoodle.Predefined +-- +import Hoodle.Type.Enum +import Hoodle.Type.PageArrangement +-- +import Prelude hiding ((.), id) + +-- | +type CanvasId = Int + +-- | +data PenDraw = PenDraw { _points :: Seq (Double,Double) } + deriving (Show) + +-- | +data ViewInfo a = (ViewMode a) => + ViewInfo { _zoomMode :: ZoomMode + , _pageArrangement :: PageArrangement a } + +xfrmViewInfo :: (ViewMode a, ViewMode b) => + (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 :: Simple Lens (ViewInfo a) ZoomMode +zoomMode = lens _zoomMode (\f a -> f { _zoomMode = a } ) + +-- | +pageArrangement :: Simple Lens (ViewInfo a) (PageArrangement a) +pageArrangement = lens _pageArrangement (\f a -> f { _pageArrangement = a }) + +-- | +data CanvasInfo a = + (ViewMode a) => CanvasInfo { _canvasId :: CanvasId + , _drawArea :: DrawingArea + , _scrolledWindow :: ScrolledWindow + , _viewInfo :: ViewInfo a + , _currentPageNum :: Int + , _horizAdjustment :: Adjustment + , _vertAdjustment :: Adjustment + , _horizAdjConnId :: Maybe (ConnectId Adjustment) + , _vertAdjConnId :: Maybe (ConnectId Adjustment) + } + +xfrmCvsInfo :: (ViewMode a, ViewMode b) => + (ViewInfo a -> ViewInfo b) + -> CanvasInfo a -> CanvasInfo b +xfrmCvsInfo f CanvasInfo {..} = + CanvasInfo { _canvasId = _canvasId + , _drawArea = _drawArea + , _scrolledWindow = _scrolledWindow + , _viewInfo = f _viewInfo + , _currentPageNum = _currentPageNum + , _horizAdjustment = _horizAdjustment + , _vertAdjustment = _vertAdjustment + , _horizAdjConnId = _horizAdjConnId + , _vertAdjConnId = _vertAdjConnId + } + +defaultCvsInfoSinglePage :: CanvasInfo SinglePage +defaultCvsInfoSinglePage = + CanvasInfo { _canvasId = error "cvsid" + , _drawArea = error "DrawingArea" + , _scrolledWindow = error "ScrolledWindow" + , _viewInfo = defaultViewInfoSinglePage + , _currentPageNum = 0 + , _horizAdjustment = error "adjustment" + , _vertAdjustment = error "vadjust" + , _horizAdjConnId = Nothing + , _vertAdjConnId = Nothing + } + +-- | +canvasId :: Simple Lens (CanvasInfo a) CanvasId +canvasId = lens _canvasId (\f a -> f { _canvasId = a }) + +-- | +drawArea :: Simple Lens (CanvasInfo a) DrawingArea +drawArea = lens _drawArea (\f a -> f { _drawArea = a }) + +-- | +scrolledWindow :: Simple Lens (CanvasInfo a) ScrolledWindow +scrolledWindow = lens _scrolledWindow (\f a -> f { _scrolledWindow = a }) + +-- | +viewInfo :: Simple Lens (CanvasInfo a) (ViewInfo a) +viewInfo = lens _viewInfo (\f a -> f { _viewInfo = a }) + +-- | +currentPageNum :: Simple Lens (CanvasInfo a) Int +currentPageNum = lens _currentPageNum (\f a -> f { _currentPageNum = a }) + +-- | +horizAdjustment :: Simple Lens (CanvasInfo a) Adjustment +horizAdjustment = lens _horizAdjustment (\f a -> f { _horizAdjustment = a }) + +-- | +vertAdjustment :: Simple Lens (CanvasInfo a) Adjustment +vertAdjustment = lens _vertAdjustment (\f a -> f { _vertAdjustment = a }) + +-- | ConnectId for horizontal scrollbar value change event +horizAdjConnId :: Simple Lens (CanvasInfo a) (Maybe (ConnectId Adjustment)) +horizAdjConnId = lens _horizAdjConnId (\f a -> f { _horizAdjConnId = a }) + +-- | ConnectId for vertical scrollbar value change event +vertAdjConnId :: Simple Lens (CanvasInfo a) (Maybe (ConnectId Adjustment)) +vertAdjConnId = lens _vertAdjConnId (\f a -> f { _vertAdjConnId = a }) + +-- | composition lens +adjustments :: Simple Lens (CanvasInfo a) (Adjustment,Adjustment) +adjustments = lens getter setter + where getter = (,) <$> view horizAdjustment <*> view vertAdjustment + setter f (h,v) = set horizAdjustment h . set vertAdjustment v $ f + + {- Lens $ (,) <$> (fst `for` horizAdjustment) + <*> (snd `for` vertAdjustment) -} + +-- | +data CanvasInfoBox = CanvasSinglePage (CanvasInfo SinglePage) + | CanvasContPage (CanvasInfo ContinuousPage) + + + +-- | apply a funtion to Generic CanvasInfo +fmap4CvsInfoBox :: (forall a. (ViewMode a)=> CanvasInfo a -> r) -> CanvasInfoBox -> r +fmap4CvsInfoBox f (CanvasSinglePage x) = f x +fmap4CvsInfoBox f (CanvasContPage x) = f x + +-- | fmap-like operation for box +insideAction4CvsInfoBox :: (forall a. CanvasInfo a -> CanvasInfo a) + -> CanvasInfoBox -> CanvasInfoBox +insideAction4CvsInfoBox f (CanvasSinglePage x) = CanvasSinglePage (f x) +insideAction4CvsInfoBox f (CanvasContPage x) = CanvasContPage (f x) + + +-- | fmap-like operation for box +insideAction4CvsInfoBoxF :: (Functor f) => + (forall a. (ViewMode a) => CanvasInfo a -> f (CanvasInfo a)) + -> CanvasInfoBox -> f CanvasInfoBox +insideAction4CvsInfoBoxF f (CanvasSinglePage x) = fmap CanvasSinglePage (f x) +insideAction4CvsInfoBoxF f (CanvasContPage x) = fmap CanvasContPage (f x) + + + +-- | +getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea +getDrawAreaFromBox = unboxGet drawArea + +-- | +unboxGet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> CanvasInfoBox -> b +unboxGet f x = fmap4CvsInfoBox (view f) x + + + + +-- | +boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b) + -> CanvasInfoBox -> m b +boxAction f c = fmap4CvsInfoBox f c + -- f (CanvasInfoBox cinfo) = f cinfo + +-- | either-like operation +selectBoxAction :: (Monad m) => + (CanvasInfo SinglePage -> m a) + -> (CanvasInfo ContinuousPage -> m a) -> CanvasInfoBox -> m a +selectBoxAction fsingle _fcont (CanvasSinglePage cinfo) = fsingle cinfo +selectBoxAction _fsingle fcont (CanvasContPage cinfo) = fcont cinfo + + +{- case view (viewInfo.pageArrangement) cinfo of + SingleArrangement _ _ _ -> fsingle cinfo + ContinuousArrangement _ _ _ _ -> fcont cinfo +-} + + +-- | +selectBox :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) + -> (CanvasInfo ContinuousPage -> CanvasInfo ContinuousPage) + -> CanvasInfoBox -> CanvasInfoBox +selectBox fs _fc (CanvasSinglePage cinfo) = CanvasSinglePage (fs cinfo) +selectBox _fs fc (CanvasContPage cinfo)= CanvasContPage (fc cinfo) + + +-- let idaction :: CanvasInfoBox -> Identity CanvasInfoBox +-- idaction = selectBoxAction (return . CanvasInfoBox . fsingle) (return . CanvasInfoBox . fcont) +-- in runIdentity . idaction + + + +{- +viewModeBranch :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) + -> (CanvasInfo ContinuousPage -> CanvasInfo ContinuousPage) + -> CanvasInfo v -> CanvasInfo v +viewModeBranch fsingle fcont cinfo = + case view (viewInfo.pageArrangement) cinfo of + SingleArrangement _ _ _ -> fsingle cinfo + ContinuousArrangement _ _ _ _ -> fcont cinfo +-} + +-- | +type CanvasInfoMap = M.IntMap CanvasInfoBox + +-- | +data WidthColorStyle = WidthColorStyle { _penWidth :: Double + , _penColor :: PenColor } + deriving (Show) + +-- | +data PenHighlighterEraserSet = PenHighlighterEraserSet + { _currPen :: WidthColorStyle + , _currHighlighter :: WidthColorStyle + , _currEraser :: WidthColorStyle + , _currText :: WidthColorStyle} + deriving (Show) + +-- | +data PenInfo = PenInfo { _penType :: PenType + , _penSet :: PenHighlighterEraserSet + , _variableWidthPen :: Bool + } + deriving (Show) + +-- | +currentTool :: Simple 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 + TextWork -> _currText . _penSet $ pinfo + setter pinfo wcs = + let pset = _penSet pinfo + psetnew = case _penType pinfo of + PenWork -> pset { _currPen = wcs } + HighlighterWork -> pset { _currHighlighter = wcs } + EraserWork -> pset { _currEraser = wcs } + TextWork -> pset { _currText = wcs } + in pinfo { _penSet = psetnew } + +-- | +defaultPenWCS :: WidthColorStyle +defaultPenWCS = WidthColorStyle predefined_medium ColorBlack + +-- | +defaultEraserWCS :: WidthColorStyle +defaultEraserWCS = WidthColorStyle predefined_eraser_medium ColorWhite + +-- | +defaultTextWCS :: WidthColorStyle +defaultTextWCS = defaultPenWCS + +-- | +defaultHighligherWCS :: WidthColorStyle +defaultHighligherWCS = WidthColorStyle predefined_highlighter_medium ColorYellow + +-- | +defaultPenInfo :: PenInfo +defaultPenInfo = + PenInfo { _penType = PenWork + , _penSet = PenHighlighterEraserSet { _currPen = defaultPenWCS + , _currHighlighter = defaultHighligherWCS + , _currEraser = defaultEraserWCS + , _currText = defaultTextWCS } + , _variableWidthPen = False + } + +makeLenses ''PenDraw +-- makeLenses ''ViewInfo +makeLenses ''PenInfo +makeLenses ''PenHighlighterEraserSet +makeLenses ''WidthColorStyle + +-- | +updateCanvasDimForSingle :: CanvasDimension + -> CanvasInfo SinglePage + -> CanvasInfo SinglePage +updateCanvasDimForSingle cdim@(CanvasDimension (Dim w' h')) cinfo = + 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) + in set (viewInfo.pageArrangement) arr' cinfo + +-- | + +updateCanvasDimForContSingle :: PageDimension + -> CanvasDimension + -> CanvasInfo ContinuousPage + -> CanvasInfo ContinuousPage +updateCanvasDimForContSingle pdim cdim@(CanvasDimension (Dim w' h')) cinfo = + 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) + in set (viewInfo.pageArrangement) arr' cinfo + diff --git a/src/Hoodle/Type/Clipboard.hs b/src/Hoodle/Type/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Clipboard.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Clipboard +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.Clipboard where + +import Control.Category +import Control.Lens +-- from hoodle-platform +import Data.Hoodle.BBox +-- +import Prelude hiding ((.), id) + +-- | +newtype Clipboard = Clipboard { unClipboard :: [StrokeBBox] } + +-- | +emptyClipboard :: Clipboard +emptyClipboard = Clipboard [] + +-- | +isEmpty :: Clipboard -> Bool +isEmpty = null . unClipboard + +-- | +getClipContents :: Clipboard -> [StrokeBBox] +getClipContents = unClipboard + +-- | +replaceClipContents :: [StrokeBBox] -> Clipboard -> Clipboard +replaceClipContents strs _ = Clipboard strs + +-- | +data SelectType = SelectRegionWork + | SelectRectangleWork + | SelectVerticalSpaceWork + | SelectHandToolWork + deriving (Show,Eq,Ord) + +-- | +data SelectInfo = SelectInfo { _selectType :: SelectType + } + deriving (Show) + +makeLenses ''SelectInfo diff --git a/src/Hoodle/Type/Coroutine.hs b/src/Hoodle/Type/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Coroutine.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Coroutine +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.Coroutine where + +-- from other packages +import Control.Applicative +import Control.Concurrent +import Control.Lens +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State +-- import Data.IORef +-- from hoodle-platform +import Control.Monad.Trans.Crtn +import Control.Monad.Trans.Crtn.Object +import qualified Control.Monad.Trans.Crtn.Driver as D +import Control.Monad.Trans.Crtn.Logger +import Control.Monad.Trans.Crtn.Queue +import Control.Monad.Trans.Crtn.World +-- from this package +import Hoodle.Type.Event +import Hoodle.Type.HoodleState +-- + +-- | +data MainOp i o where + DoEvent :: MainOp MyEvent () + +doEvent :: (Monad m) => MyEvent -> CObjT MainOp m () +doEvent ev = request (Arg DoEvent ev) >> return () + +-- | +type MainCoroutine = MainObjB + +type MainObjB = SObjBT MainOp (StateT HoodleState WorldObjB) + +-- | +type MainObj = SObjT MainOp (StateT HoodleState WorldObjB) + +-- | +nextevent :: MainCoroutine MyEvent +nextevent = do Arg DoEvent ev <- request (Res DoEvent ()) + return ev + +-- | +type WorldObj = SObjT (WorldOp MyEvent DriverB) DriverB + +-- | +type WorldObjB = SObjBT (WorldOp MyEvent DriverB) DriverB + +-- | +world :: HoodleState -> MainObj () -> WorldObj () +world xstate initmc = ReaderT staction + where + staction req = runStateT (go initmc req) xstate >> return () + go :: MainObj () + -> Arg (WorldOp MyEvent DriverB) + -> StateT HoodleState WorldObjB () + go mcobj (Arg GiveEvent ev) = do + Right mcobj' <- runErrorT $ liftM fst (mcobj <==| doEvent ev) + req <- lift $ request (Res GiveEvent ()) + go mcobj' req + go mcobj (Arg FlushLog logobj) = do + logf <- (^. tempLog) <$> get + let msg = logf "" + if ((not.null) msg) + then do + Right logobj' <- lift . lift $ runErrorT $ + liftM fst (logobj <==| writeLog msg) + modify (tempLog .~ id) + req <- lift $ request (Res FlushLog logobj') + go mcobj req + else do + req <- lift $ request Ign + go mcobj req + go mcobj (Arg FlushQueue ()) = do + q <- (^. tempQueue) <$> get + let lst = fqueue q ++ reverse (bqueue q) + modify (tempQueue .~ emptyQueue) + req <- lift $ request (Res FlushQueue lst) + go mcobj req + + + + +-- | +type Driver a = D.Driver MyEvent IO a -- SObjT MainOp IO a + +-- | +type DriverB = SObjBT (D.DrvOp MyEvent) IO + +-- | +type EventVar = MVar (Maybe (Driver ())) + + + + diff --git a/src/Hoodle/Type/Enum.hs b/src/Hoodle/Type/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Enum.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Enum +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.Enum where + +import qualified Data.ByteString.Char8 as B +import qualified Data.Map as M +import Data.Maybe +-- +import Data.Hoodle.Predefined + +-- | page add direction + +data AddDirection = PageBefore | PageAfter + deriving (Show,Eq,Ord,Enum) + +-- | relative zoom mode + +data ZoomModeRel = ZoomIn | ZoomOut + deriving (Show,Eq,Ord,Enum) + +-- | +data PenType = PenWork + | HighlighterWork + | EraserWork + | TextWork + deriving (Show,Eq,Ord) + +-- | +data PenColor = ColorBlack + | ColorBlue + | ColorRed + | ColorGreen + | ColorGray + | ColorLightBlue + | ColorLightGreen + | ColorMagenta + | ColorOrange + | ColorYellow + | ColorWhite + | ColorRGBA Double Double Double Double + deriving (Show,Eq,Ord) + +penColorNameMap :: M.Map PenColor B.ByteString +penColorNameMap = M.fromList [ (ColorBlack, "black") + , (ColorBlue , "blue") + , (ColorRed , "red") + , (ColorGreen, "green") + , (ColorGray, "gray") + , (ColorLightBlue, "lightblue") + , (ColorLightGreen, "lightgreen") + , (ColorMagenta, "magenta") + , (ColorOrange, "orange") + , (ColorYellow, "yellow") + , (ColorWhite, "white") ] + +penColorRGBAmap :: M.Map PenColor (Double,Double,Double,Double) +penColorRGBAmap = M.fromList $ map (\x->(fst x,fromJust (M.lookup (snd x) predefined_pencolor))) + $ M.toList penColorNameMap + +convertPenColorToRGBA :: PenColor -> (Double,Double,Double,Double) +convertPenColorToRGBA (ColorRGBA r g b a) = (r,g,b,a) +convertPenColorToRGBA c = fromJust (M.lookup c penColorRGBAmap) + diff --git a/src/Hoodle/Type/Event.hs b/src/Hoodle/Type/Event.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Event.hs @@ -0,0 +1,154 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Event +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.Event where + +-- from other package +import Graphics.UI.Gtk +-- from hoodle-platform +-- import Data.Hoodle.BBox +import Data.Hoodle.Simple +-- from this package +import Hoodle.Device +import Hoodle.Type.Clipboard +import Hoodle.Type.Enum + +-- | + +data MyEvent = Initialized + | CanvasConfigure Int Double Double + | UpdateCanvas Int + | PenDown Int PenButton PointerCoord + | PenMove Int PointerCoord + | PenUp Int PointerCoord + | PenColorChanged PenColor + | PenWidthChanged Int -- (PenType -> Double) + | AssignPenMode (Either PenType SelectType) + | HScrollBarMoved Int Double + | VScrollBarMoved Int Double + | VScrollBarStart Int Double + | VScrollBarEnd Int Double + | PaneMoveStart + | PaneMoveEnd + | ToViewAppendMode + | ToSelectMode + | ToSinglePage + | ToContSinglePage + | Menu MenuEvent + | ActionOrdered + | GotOk + | OkCancel Bool + | FileChosen (Maybe FilePath) + | GotClipboardContent (Maybe [Item]) + -- | EventConnected + | EventDisconnected + deriving (Show,Eq,Ord) + + +-- | +data MenuEvent = MenuNew + | MenuAnnotatePDF + | MenuLoadImage + | MenuOpen + | MenuSave + | MenuSaveAs + | MenuReload + | MenuRecentDocument + | MenuPrint + | MenuExport + | MenuQuit + | MenuUndo + | MenuRedo + | MenuCut + | MenuCopy + | MenuPaste + | MenuDelete + -- | MenuNetCopy + -- | MenuNetPaste + | MenuFullScreen + | MenuZoom + | MenuZoomIn + | MenuZoomOut + | MenuNormalSize + | MenuPageWidth + | MenuPageHeight + | MenuSetZoom + | MenuFirstPage + | MenuPreviousPage + | MenuNextPage + | MenuLastPage + | MenuShowLayer + | MenuHideLayer + | MenuHSplit + | MenuVSplit + | MenuDelCanvas + | MenuNewPageBefore + | MenuNewPageAfter + | MenuNewPageAtEnd + | MenuDeletePage + | MenuNewLayer + | MenuNextLayer + | MenuPrevLayer + | MenuGotoLayer + | MenuDeleteLayer + | MenuPaperSize + | MenuPaperColor + | MenuPaperStyle + | MenuApplyToAllPages + | MenuLoadBackground + | MenuBackgroundScreenshot + | MenuDefaultPaper + | MenuSetAsDefaultPaper + | MenuShapeRecognizer + | MenuRuler + | MenuSelectRegion + | MenuSelectRectangle + | MenuVerticalSpace + | MenuHandTool + | MenuPenOptions + | MenuEraserOptions + | MenuHighlighterOptions + | MenuTextFont + | MenuDefaultPen + | MenuDefaultEraser + | MenuDefaultHighlighter + | MenuDefaultText + | MenuSetAsDefaultOption + | MenuRelaunch + | MenuUseXInput + | MenuDiscardCoreEvents + | MenuEraserTip + | MenuPressureSensitivity + | MenuPageHighlight + | MenuMultiplePageView + | MenuMultiplePages + | MenuButton2Mapping + | MenuButton3Mapping + | MenuAntialiasedBitmaps + | MenuProgressiveBackgrounds + | MenuPrintPaperRuling + | MenuLeftHandedScrollbar + | MenuShortenMenus + | MenuAutoSavePreferences + | MenuSavePreferences + | MenuAbout + | MenuDefault + deriving (Show, Ord, Eq) + +viewModeToMyEvent :: RadioAction -> IO MyEvent +viewModeToMyEvent a = do + v <- radioActionGetCurrentValue a + case v of + 1 -> return ToSinglePage + 0 -> return ToContSinglePage + _ -> return ToSinglePage + diff --git a/src/Hoodle/Type/HoodleState.hs b/src/Hoodle/Type/HoodleState.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/HoodleState.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.HoodleState +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.HoodleState +( HoodleState(..) +, HoodleModeState(..) +, IsOneTimeSelectMode(..) +-- | labels +, hoodleModeState +, currFileName +, cvsInfoMap +, currentCanvas +, frameState +, rootWindow +, rootContainer +, rootOfRootWindow +, currentPenDraw +, callBack +, deviceList +, penInfo +, selectInfo +, gtkUIManager +, isSaved +, undoTable +, isOneTimeSelectMode +, pageModeSignal +, lastTimeCanvasConfigure +, hookSet +, tempLog +, tempQueue +-- | others +, emptyHoodleState +, getHoodle +-- | additional lenses +, getCanvasInfoMap +, setCanvasInfoMap +, getCurrentCanvasId +, setCurrentCanvasId +, currentCanvasInfo +, resetHoodleModeStateBuffers +, getCanvasInfo +, setCanvasInfo +, updateFromCanvasInfoAsCurrentCanvas +, setCanvasId +, modifyCanvasInfo +-- , modifyCurrentCanvasInfo +-- , modifyCurrCvsInfoM +, hoodleModeStateEither +, getCurrentPageFromHoodleModeState +, getCurrentPageDimFromHoodleModeState +-- | for debug +, showCanvasInfoMapViewPortBBox +) where + +import Control.Category +import Control.Lens +import Control.Monad.State hiding (get,modify) +import qualified Data.IntMap as M +import Data.Maybe +import Data.Time.Clock +import Graphics.UI.Gtk hiding (Clipboard, get,set) +-- from hoodle-platform +import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Queue +import Data.Hoodle.Generic +import Data.Hoodle.Select +-- import Data.Hoodle.Map +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type +-- from this package +import Hoodle.Device +import Hoodle.Script.Hook +import Hoodle.Type.Event +import Hoodle.Type.Canvas +import Hoodle.Type.Clipboard +import Hoodle.Type.Window +import Hoodle.Type.Undo +import Hoodle.Type.Alias +import Hoodle.Type.PageArrangement +import Hoodle.Util +-- +import Prelude hiding ((.), id) + + +-- type HoodleModeStateIO = StateT HoodleState IO + +-- | + +data HoodleModeState = ViewAppendState { unView :: RHoodle } + | SelectState { tempSelect :: HHoodle } + +-- | + +data IsOneTimeSelectMode = NoOneTimeSelectMode + | YesBeforeSelect + | YesAfterSelect + deriving (Show,Eq,Ord) + +data HoodleState = + HoodleState { _hoodleModeState :: HoodleModeState + , _currFileName :: Maybe FilePath + , _cvsInfoMap :: CanvasInfoMap + , _currentCanvas :: (CanvasId,CanvasInfoBox) + , _frameState :: WindowConfig + , _rootWindow :: Widget + , _rootContainer :: Box + , _rootOfRootWindow :: Window + , _currentPenDraw :: PenDraw + -- , _clipboard :: Clipboard + , _callBack :: MyEvent -> IO () + , _deviceList :: DeviceList + , _penInfo :: PenInfo + , _selectInfo :: SelectInfo + , _gtkUIManager :: UIManager + , _isSaved :: Bool + , _undoTable :: UndoTable HoodleModeState + , _isOneTimeSelectMode :: IsOneTimeSelectMode + , _pageModeSignal :: Maybe (ConnectId RadioAction) + , _lastTimeCanvasConfigure :: Maybe UTCTime + , _hookSet :: Maybe Hook + , _tempQueue :: Queue (Either (ActionOrder MyEvent) MyEvent) + , _tempLog :: String -> String + } + + +makeLenses ''HoodleState + +emptyHoodleState :: HoodleState +emptyHoodleState = + HoodleState + { _hoodleModeState = ViewAppendState emptyGHoodle + , _currFileName = Nothing + , _cvsInfoMap = error "emptyHoodleState.cvsInfoMap" + , _currentCanvas = error "emtpyHoodleState.currentCanvas" + , _frameState = error "emptyHoodleState.frameState" + , _rootWindow = error "emtpyHoodleState.rootWindow" + , _rootContainer = error "emptyHoodleState.rootContainer" + , _rootOfRootWindow = error "emptyHoodleState.rootOfRootWindow" + , _currentPenDraw = emptyPenDraw + -- , _clipboard = emptyClipboard + , _callBack = error "emtpyHoodleState.callBack" + , _deviceList = error "emtpyHoodleState.deviceList" + , _penInfo = defaultPenInfo + , _selectInfo = SelectInfo SelectRectangleWork + , _gtkUIManager = error "emptyHoodleState.gtkUIManager" + , _isSaved = False + , _undoTable = emptyUndo 1 + -- , _isEventBlocked = False + , _isOneTimeSelectMode = NoOneTimeSelectMode + , _pageModeSignal = Nothing + , _lastTimeCanvasConfigure = Nothing + , _hookSet = Nothing + , _tempQueue = emptyQueue + , _tempLog = id + } + +-- | + +getHoodle :: HoodleState -> Hoodle EditMode +getHoodle = either id makehdl . hoodleModeStateEither . view hoodleModeState + where makehdl thdl = GHoodle (view gselTitle thdl) (view gselAll thdl) + + +-- | + +getCurrentCanvasId :: HoodleState -> CanvasId +getCurrentCanvasId = fst . _currentCanvas + +-- | + +setCurrentCanvasId :: CanvasId -> HoodleState -> Maybe HoodleState +setCurrentCanvasId a f = do + cinfobox <- M.lookup a (_cvsInfoMap f) + return (f { _currentCanvas = (a,cinfobox) }) + +-- | + +getCanvasInfoMap :: HoodleState -> CanvasInfoMap +getCanvasInfoMap = _cvsInfoMap + +-- | + +setCanvasInfoMap :: CanvasInfoMap -> HoodleState -> Maybe HoodleState +setCanvasInfoMap cmap xstate + | M.null cmap = Nothing + | otherwise = + let (cid,_) = _currentCanvas xstate + (cidmax,cinfomax) = M.findMax cmap + mcinfobox = M.lookup cid cmap + in Just . maybe (xstate {_currentCanvas=(cidmax,cinfomax), _cvsInfoMap = cmap}) + (\cinfobox -> xstate {_currentCanvas = (cid,cinfobox) + ,_cvsInfoMap = cmap }) + $ mcinfobox + +currentCanvasInfo :: Simple Lens HoodleState CanvasInfoBox +currentCanvasInfo = lens getter setter + where + getter = snd . _currentCanvas + setter f a = + let cid = fst . _currentCanvas $ f + cmap' = M.adjust (const a) cid (_cvsInfoMap f) + in f { _currentCanvas = (cid,a), _cvsInfoMap = cmap' } + +resetHoodleModeStateBuffers :: HoodleModeState -> IO HoodleModeState +resetHoodleModeStateBuffers hdlmodestate1 = + case hdlmodestate1 of + ViewAppendState hdl -> liftIO . liftM ViewAppendState . updateHoodleBuf $ hdl + _ -> return hdlmodestate1 + +-- | + +getCanvasInfo :: CanvasId -> HoodleState -> CanvasInfoBox +getCanvasInfo cid xstate = + let cinfoMap = getCanvasInfoMap xstate + maybeCvs = M.lookup cid cinfoMap + in maybeError ("no canvas with id = " ++ show cid) maybeCvs + +-- | + +setCanvasInfo :: (CanvasId,CanvasInfoBox) -> HoodleState -> HoodleState +setCanvasInfo (cid,cinfobox) xstate = + let cmap = getCanvasInfoMap xstate + cmap' = M.insert cid cinfobox cmap + in maybe xstate id $ setCanvasInfoMap cmap' xstate + + + +-- | change current canvas. this is the master function + +updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> HoodleState -> HoodleState +updateFromCanvasInfoAsCurrentCanvas cinfobox xstate = + let cid = unboxGet canvasId cinfobox + cmap = getCanvasInfoMap xstate + cmap' = M.insert cid cinfobox cmap + -- implement the following later + -- page = gcast (unboxGet currentPage cinfobox) :: Page EditMode + in xstate { _currentCanvas = (cid,cinfobox) + , _cvsInfoMap = cmap' } + +-- | + +setCanvasId :: CanvasId -> CanvasInfoBox -> CanvasInfoBox +setCanvasId cid = insideAction4CvsInfoBox (set canvasId cid) + + + -- (CanvasInfoBox cinfo) = CanvasInfoBox (cinfo { _canvasId = cid }) + + +-- | + +modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) -> HoodleState + -> HoodleState +modifyCanvasInfo cid f xstate = + maybe xstate id . flip setCanvasInfoMap xstate + . M.adjust f cid . getCanvasInfoMap + $ xstate + + +{- +-- | should be deprecated +modifyCurrentCanvasInfo :: (CanvasInfoBox -> CanvasInfoBox) + -> HoodleState + -> HoodleState +modifyCurrentCanvasInfo f = over currentCanvasInfo f +-} + +{- +-- | should be deprecated +modifyCurrCvsInfoM :: (Monad m) => (CanvasInfoBox -> m CanvasInfoBox) + -> HoodleState + -> m HoodleState +modifyCurrCvsInfoM f st = do + let cinfobox = view currentCanvasInfo st + cid = getCurrentCanvasId st + ncinfobox <- f cinfobox + let cinfomap = getCanvasInfoMap st + ncinfomap = M.adjust (const ncinfobox) cid cinfomap + maybe (return st) return (setCanvasInfoMap ncinfomap st) +-} + +-- | + +hoodleModeStateEither :: HoodleModeState -> Either (Hoodle EditMode) (Hoodle SelectMode) +hoodleModeStateEither hdlmodst = case hdlmodst of + ViewAppendState hdl -> Left hdl + SelectState thdl -> Right thdl + +-- | + +getCurrentPageFromHoodleModeState :: (ViewMode a) => CanvasInfo a + -> HoodleModeState -> Page EditMode +getCurrentPageFromHoodleModeState cinfo hdlmodst = + let cpn = view currentPageNum cinfo + pagemap = getPageMapFromHoodleModeState hdlmodst + in maybeError "updatePageFromCanvasToHoodle" $ M.lookup cpn pagemap + +-- | + +getCurrentPageDimFromHoodleModeState :: (ViewMode a) => CanvasInfo a + -> HoodleModeState -> PageDimension +getCurrentPageDimFromHoodleModeState cinfo = + PageDimension . view gdimension . getCurrentPageFromHoodleModeState cinfo + + +-- | + +getPageMapFromHoodleModeState :: HoodleModeState -> M.IntMap (Page EditMode) +getPageMapFromHoodleModeState = either (view gpages) (view gselAll) . hoodleModeStateEither + + +-- | + +showCanvasInfoMapViewPortBBox :: HoodleState -> IO () +showCanvasInfoMapViewPortBBox xstate = do + let cmap = getCanvasInfoMap xstate + print . map (unboxGet (viewInfo.pageArrangement.viewPortBBox)) . M.elems $ cmap + + + + diff --git a/src/Hoodle/Type/PageArrangement.hs b/src/Hoodle/Type/PageArrangement.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/PageArrangement.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE EmptyDataDecls, GADTs, TypeOperators, GeneralizedNewtypeDeriving, NoMonoPatBinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.PageArrangement +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.PageArrangement where + +-- from other packages +import Control.Applicative +import Control.Category ((.)) +import Control.Lens +import Data.Foldable (toList) +import Data.Maybe (fromJust) +-- from hoodle-platform +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Generic +import Data.Hoodle.BBox +-- from this package +import Hoodle.Type.Predefined +import Hoodle.Type.Alias +import Hoodle.Util +-- +import Prelude hiding ((.),id) + + +-- | + +data ZoomMode = Original | FitWidth | FitHeight | Zoom Double + deriving (Show,Eq) + +-- | sum type class (later, will be replaced by Kind promotion) +data ViewModeSumType = VMSinglePage | VMContPage + +class ViewMode a + +-- | only one page show at a time +data SinglePage = SinglePage + +-- | +instance ViewMode SinglePage + +-- | continuously show pages in general +data ContinuousPage = ContinuousPage + +-- | +instance ViewMode ContinuousPage + +-- | +newtype PageNum = PageNum { unPageNum :: Int } + deriving (Eq,Show,Ord,Num) + +-- | +newtype ScreenCoordinate = ScrCoord { unScrCoord :: (Double,Double) } + deriving (Show) + +-- | +newtype CanvasCoordinate = CvsCoord { unCvsCoord :: (Double,Double) } + deriving (Show) + +-- | +newtype DesktopCoordinate = DeskCoord { unDeskCoord :: (Double,Double) } + deriving (Show) + +-- | +newtype PageCoordinate = PageCoord { unPageCoord :: (Double,Double) } + deriving (Show) + +-- | +newtype ScreenDimension = ScreenDimension { unScreenDimension :: Dimension } + deriving (Show) + +-- | +newtype CanvasDimension = CanvasDimension { unCanvasDimension :: Dimension } + deriving (Show) + +-- | +newtype CanvasOrigin = CanvasOrigin { unCanvasOrigin :: (Double,Double) } + deriving (Show) + +-- | +newtype PageOrigin = PageOrigin { unPageOrigin :: (Double,Double) } + deriving (Show) + +-- | +newtype PageDimension = PageDimension { unPageDimension :: Dimension } + deriving (Show) + +-- | +newtype DesktopDimension = DesktopDimension { unDesktopDimension :: Dimension } + deriving (Show) + +-- | +newtype ViewPortBBox = ViewPortBBox { unViewPortBBox :: BBox } + deriving (Show) + +-- | +apply :: (BBox -> BBox) -> ViewPortBBox -> ViewPortBBox +apply f (ViewPortBBox bbox1) = ViewPortBBox (f bbox1) +{-# INLINE apply #-} + +-- | data structure for coordinate arrangement of pages in desktop coordinate +data PageArrangement a where + SingleArrangement :: CanvasDimension + -> PageDimension + -> ViewPortBBox + -> PageArrangement SinglePage + ContinuousArrangement :: CanvasDimension + -> DesktopDimension + -> (PageNum -> Maybe (PageOrigin,PageDimension)) + -> ViewPortBBox + -> PageArrangement ContinuousPage + + +-- | +getRatioPageCanvas :: ZoomMode -> PageDimension -> CanvasDimension -> (Double,Double) +getRatioPageCanvas zmode (PageDimension (Dim w h)) (CanvasDimension (Dim w' h')) = + case zmode of + Original -> (1.0,1.0) + FitWidth -> (w'/w,w'/w) + FitHeight -> (h'/h,h'/h) + Zoom s -> (s,s) + +-- | +makeSingleArrangement :: ZoomMode + -> PageDimension + -> CanvasDimension + -> (Double,Double) + -> PageArrangement SinglePage +makeSingleArrangement zmode pdim cdim@(CanvasDimension (Dim w' h')) (x,y) = + let (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim + bbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy) + in SingleArrangement cdim pdim (ViewPortBBox bbox) + +-- | +data DesktopConstraint = DesktopWidthConstrained Double + + +-- | +makeContinuousArrangement :: ZoomMode + -> CanvasDimension + -> Hoodle EditMode + -> (PageNum,PageCoordinate) + -> PageArrangement ContinuousPage +makeContinuousArrangement zmode cdim@(CanvasDimension (Dim cw ch)) + hdl (pnum,PageCoord (xpos,ypos)) = + let dim = view gdimension . head . toList . view gpages $ hdl + (sinvx,sinvy) = getRatioPageCanvas zmode (PageDimension dim) cdim + cnstrnt = DesktopWidthConstrained (cw/sinvx) + (PageOrigin (x0,y0),_) = maybeError "makeContArr" $ pageArrFuncCont cnstrnt hdl pnum + (x1,y1) = (xpos+x0,ypos+y0) + (x2,y2) = (xpos+x0+cw/sinvx,ypos+y0+ch/sinvy) + ddim@(DesktopDimension (Dim w h)) = deskDimCont cnstrnt hdl + (x1',x2') + | x2>w && w-(x2-x1)>0 = (w-(x2-x1),w) + | x2>w && w-(x2-x1)<=0 = (0,x2-x1) + | otherwise = (x1,x2) + (y1',y2') + | y2>h && h-(y2-y1)>0 = (h-(y2-y1),h) + | y2>h && h-(y2-y1)<=0 = (0,y2-y1) + | otherwise = (y1,y2) + vport = ViewPortBBox (BBox (x1',y1') (x2',y2') ) + in ContinuousArrangement cdim ddim (pageArrFuncCont cnstrnt hdl) vport + +-- | +pageArrFuncCont :: DesktopConstraint + -> Hoodle EditMode + -> PageNum + -> Maybe (PageOrigin,PageDimension) +pageArrFuncCont (DesktopWidthConstrained w') hdl (PageNum n) + | n < 0 = Nothing + | n >= len = Nothing + | otherwise = Just (PageOrigin (xys !! n), PageDimension (pdims !! n)) + where addf (x,y) (w,h) = if x+2*w+predefinedPageSpacing < w' + then (x+w+predefinedPageSpacing,y) + else (0,y+h+predefinedPageSpacing) + pgs = toList . view gpages $ hdl + len = length pgs + pdims = map (view gdimension) pgs + wh2xyFrmPg = ((,) <$> dim_width <*> dim_height) . view gdimension + xys = scanl addf (0,0) . map wh2xyFrmPg $ pgs + +-- | +deskDimCont :: DesktopConstraint -> Hoodle EditMode -> DesktopDimension +deskDimCont cnstrnt hdl = + let pgs = toList . view gpages $ hdl + len = length pgs + olst = map (fromJust . pageArrFuncCont cnstrnt hdl . PageNum) [0..len-1] + f (PageOrigin (x,y),PageDimension (Dim w h)) (Dim w' h') = + let w'' = if w' < x+w then x+w else w' + h'' = if h' < y+h then y+h else h' + in Dim w'' h'' + in DesktopDimension $ foldr f (Dim 0 0) olst + +------------ +-- lenses +------------ + +-- | +pageDimension :: Simple Lens (PageArrangement SinglePage) PageDimension +pageDimension = lens getter setter + where getter (SingleArrangement _ pdim _) = pdim + getter (ContinuousArrangement _ _ _ _) = error $ "in pageDimension " -- partial + setter (SingleArrangement cdim _ vbbox) pdim = SingleArrangement cdim pdim vbbox + setter (ContinuousArrangement _ _ _ _) _pdim = error $ "in pageDimension " -- partial + +-- | +canvasDimension :: Simple Lens (PageArrangement a) CanvasDimension +canvasDimension = lens getter setter + where + getter :: PageArrangement a -> CanvasDimension + getter (SingleArrangement cdim _ _) = cdim + getter (ContinuousArrangement cdim _ _ _) = cdim + setter :: PageArrangement a -> CanvasDimension -> PageArrangement a + setter (SingleArrangement _ pdim vbbox) cdim = SingleArrangement cdim pdim vbbox + setter (ContinuousArrangement _ ddim pfunc vbbox) cdim = + ContinuousArrangement cdim ddim pfunc vbbox + +-- | +viewPortBBox :: Simple Lens (PageArrangement a) ViewPortBBox +viewPortBBox = lens getter setter + where + getter :: PageArrangement a -> ViewPortBBox + getter (SingleArrangement _ _ vbbox) = vbbox + getter (ContinuousArrangement _ _ _ vbbox) = vbbox + setter :: PageArrangement a -> ViewPortBBox -> PageArrangement a + setter (SingleArrangement cdim pdim _) vbbox = SingleArrangement cdim pdim vbbox + setter (ContinuousArrangement cdim ddim pfunc _) vbbox = + ContinuousArrangement cdim ddim pfunc vbbox + +-- | +desktopDimension :: Simple Lens (PageArrangement a) DesktopDimension +desktopDimension = lens getter (error "setter for desktopDimension is not defined") + where getter :: PageArrangement a -> DesktopDimension + getter (SingleArrangement _ (PageDimension dim) _) = DesktopDimension dim + getter (ContinuousArrangement _ ddim _ _) = ddim + + + +{- +-- | +pageFunction :: PageArrangement ContinuousSinglePage -> PageNum -> Maybe PageOrigin +pageFunction (ContinuousSingleArrangement _ _ pfunc _ ) = pfunc + +-- | +pageArrEither :: PageArrangement a + -> Either (PageArrangement SinglePage) (PageArrangement ContinuousSinglePage) +pageArrEither arr@(SingleArrangement _ _ _) = Left arr +pageArrEither arr@(ContinuousSingleArrangement _ _ _ _) = Right arr + +-} + + +{- PageOrigin (w',h') = maybeError + ("deskdimCont" ++ + show (map (pageArrFuncCont cdim hdl . PageNum) [0..5])) + $ pageArrFuncCont cdim hdl + (PageNum . (\x->x-1) . length $ plst ) + Dim _ h2 = view g_dimension (last plst) + h = h' + h2 + w = maximum . map (dim_width.view g_dimension) $ plst + in DesktopDimension (Dim w h) -} + + +{- --- previous version +-- | +pageArrFuncCont :: Hoodle EditMode -> PageNum -> Maybe PageOrigin +pageArrFuncCont hdl (PageNum n) + | n < 0 = Nothing + | n >= len = Nothing + | otherwise = Just (PageOrigin (0,ys !! n)) + where addf x y = x + y + predefinedPageSpacing + pgs = gToList . view g_pages $ hdl + len = length pgs + ys = scanl addf 0 . map (dim_height.view g_dimension) $ pgs +-} + +{- --- previous version +-- | +deskDimCont :: Hoodle EditMode -> DesktopDimension +deskDimCont hdl = + let plst = gToList . view g_pages $ hdl + PageOrigin (_,h') = maybeError + ("deskdimCont" ++ + show (map (pageArrFuncCont hdl . PageNum) [0..5])) + $ pageArrFuncCont hdl + (PageNum . (\x->x-1) . length $ plst ) + Dim _ h2 = view g_dimension (last plst) + h = h' + h2 + w = maximum . map (dim_width.view g_dimension) $ plst + in DesktopDimension (Dim w h) +-} + + diff --git a/src/Hoodle/Type/Predefined.hs b/src/Hoodle/Type/Predefined.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Predefined.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Predefined +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +---------------------------------------------------------------------------- + +module Hoodle.Type.Predefined where + +import Data.Time.Clock + +-- | + +dtime_bound :: NominalDiffTime +dtime_bound = realToFrac (picosecondsToDiffTime 100000000000) + +-- | + +predefinedWinReconfTimeBound :: NominalDiffTime +predefinedWinReconfTimeBound = realToFrac (picosecondsToDiffTime 50000000000) + +-- | + +predefinedLassoColor :: (Double,Double,Double,Double) +predefinedLassoColor = (1.0,116.0/255.0,0,0.8) + +-- | + +predefinedLassoWidth :: Double +predefinedLassoWidth = 4.0 + +-- | + +predefinedLassoDash :: ([Double],Double) +predefinedLassoDash = ([10,5],10) + +-- | + +predefinedPageSpacing :: Double +predefinedPageSpacing = 10 + +-- | + +predefinedZoomStepFactor :: Double +predefinedZoomStepFactor = 1.5 + diff --git a/src/Hoodle/Type/Undo.hs b/src/Hoodle/Type/Undo.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Undo.hs @@ -0,0 +1,54 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Undo +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +module Hoodle.Type.Undo where + +import Data.Hoodle.Zipper + +data UndoTable a = UndoTable { undo_allowednum :: Int + , undo_totalnum :: Int + , undo_zipper :: Maybe (SeqZipper a) + } + +emptyUndo :: Int -> UndoTable a +emptyUndo n | n > 0 = UndoTable n 0 Nothing + | otherwise = error "undo table must be larger than 0" + +singletonUndo :: Int -> a -> UndoTable a +singletonUndo n e = addToUndo (emptyUndo n) e + +addToUndo :: UndoTable a -> a -> UndoTable a +addToUndo utable e = + let tn = undo_totalnum utable + an = undo_allowednum utable + mzs = undo_zipper utable + in case mzs of + Nothing -> UndoTable an 1 . Just . singletonSZ $ e + Just zs -> + if tn < an + then UndoTable an (tn+1) . Just . appendGoLast zs $ e + else UndoTable an an . chopFirst . appendGoLast zs $ e + +getCurrentUndoItem :: UndoTable a -> Maybe a +getCurrentUndoItem = fmap current . undo_zipper + +getPrevUndo :: UndoTable a -> Maybe (a, UndoTable a) +getPrevUndo t = do + newzs <- moveLeft =<< undo_zipper t + return (current newzs, t {undo_zipper = Just newzs}) + +getNextUndo :: UndoTable a -> Maybe (a, UndoTable a) +getNextUndo t = do + newzs <- moveRight =<< undo_zipper t + return (current newzs, t {undo_zipper = Just newzs}) + +numOfUndo :: UndoTable a -> Int +numOfUndo = undo_totalnum diff --git a/src/Hoodle/Type/Window.hs b/src/Hoodle/Type/Window.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Type/Window.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Type.Window +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Type.Window where + +import Hoodle.Type.Canvas + +-- | + +data WindowConfig = Node CanvasId + | HSplit WindowConfig WindowConfig + | VSplit WindowConfig WindowConfig + deriving (Show,Eq) + +data SplitType = SplitHorizontal | SplitVertical + deriving (Show) + +-- | split window in the place of cidold + +splitWindow :: CanvasId -- ^ old window + -> (CanvasId, SplitType) -- ^ new additional window + -> WindowConfig -- ^ old WindowConfig + -> Either WindowConfig WindowConfig -- ^ new WindowConfig +splitWindow cidold (cidnew,stype) (Node cid) = + if cid == cidold + then case stype of + SplitHorizontal -> Right (HSplit (Node cid) (Node cidnew)) + SplitVertical -> Right (VSplit (Node cid) (Node cidnew)) + else Left (Node cid) +splitWindow cidold (cidnew,stype) (HSplit wconf1 wconf2) = + let r1 = splitWindow cidold (cidnew,stype) wconf1 + r2 = splitWindow cidold (cidnew,stype) wconf2 + in case (r1,r2) of + (Left nwconf1, Left nwconf2) -> Left (HSplit nwconf1 nwconf2) + (Left nwconf1, Right nwconf2) -> Right (HSplit nwconf1 nwconf2) + (Right nwconf1, Left nwconf2) -> Right (HSplit nwconf1 nwconf2) + (Right _, Right _) -> error "such case cannot happen in splitWindow" +splitWindow cidold (cidnew,stype) (VSplit wconf1 wconf2) = + let r1 = splitWindow cidold (cidnew,stype) wconf1 + r2 = splitWindow cidold (cidnew,stype) wconf2 + in case (r1,r2) of + (Left nwconf1, Left nwconf2) -> Left (VSplit nwconf1 nwconf2) + (Left nwconf1, Right nwconf2) -> Right (VSplit nwconf1 nwconf2) + (Right nwconf1, Left nwconf2) -> Right (VSplit nwconf1 nwconf2) + (Right _, Right _) -> error "such case cannot happen in splitWindow" + + +removeWindow :: CanvasId -- ^ canvas id + -> WindowConfig + -> Either WindowConfig (Maybe WindowConfig) +removeWindow cid (Node cid') = + if cid == cid' + then Right Nothing + else Left (Node cid') +removeWindow cid (HSplit wconf1 wconf2) = + let r1 = removeWindow cid wconf1 + r2 = removeWindow cid wconf2 + in case (r1,r2) of + (Left nwconf1, Left nwconf2) -> Left (HSplit nwconf1 nwconf2) + (Left nwconf1, Right mnwconf2) -> + case mnwconf2 of + Just nwconf2 -> Right (Just (HSplit nwconf1 nwconf2)) + Nothing -> Right (Just nwconf1) + (Right mnwconf1, Left nwconf2) -> + case mnwconf1 of + Just nwconf1 -> Right (Just (HSplit nwconf1 nwconf2)) + Nothing -> Right (Just nwconf2) + (Right _, Right _) -> error "such case cannot happen in removeWindow" +removeWindow cid (VSplit wconf1 wconf2) = + let r1 = removeWindow cid wconf1 + r2 = removeWindow cid wconf2 + in case (r1,r2) of + (Left nwconf1, Left nwconf2) -> Left (VSplit nwconf1 nwconf2) + (Left nwconf1, Right mnwconf2) -> + case mnwconf2 of + Just nwconf2 -> Right (Just (VSplit nwconf1 nwconf2)) + Nothing -> Right (Just nwconf1) + (Right mnwconf1, Left nwconf2) -> + case mnwconf1 of + Just nwconf1 -> Right (Just (VSplit nwconf1 nwconf2)) + Nothing -> Right (Just nwconf2) + (Right _, Right _) -> error "such case cannot happen in removeWindow" + diff --git a/src/Hoodle/Util.hs b/src/Hoodle/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Util.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Util +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Util where + +import Data.Maybe +import Data.Hoodle.Simple + +-- import Data.Time.Clock +-- import Data.Time.Format +-- import System.Locale + +-- for test +-- import Blaze.ByteString.Builder +-- import Text.Hoodle.Builder + +{- +testPage :: Page Edit -> IO () +testPage page = do + let pagesimple = toPage bkgFromBkgPDF . tpageBBoxMapPDFFromTPageBBoxMapPDFBuf $ page + L.putStrLn . toLazyByteString . Text.Hoodle.Builder.fromPage $ pagesimple +-} + + +{- +testHoodle :: HoodleState -> IO () +testHoodle hdlstate = do + let hdlsimple :: Hoodle = case hdlstate of + ViewAppendState hdl -> xournalFromTHoodleSimple (gcast hdl :: THoodleSimple) + SelectState thdl -> xournalFromTHoodleSimple (gcast thdl :: THoodleSimple) + L.putStrLn (builder hdlsimple) +-} + +maybeFlip :: Maybe a -> b -> (a->b) -> b +maybeFlip m n j = maybe n j m + +uncurry4 :: (a->b->c->d->e)->(a,b,c,d)->e +uncurry4 f (x,y,z,w) = f x y z w + +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + +maybeError :: String -> Maybe a -> a +maybeError str = maybe (error str) id + +getLargestWidth :: Hoodle -> Double +getLargestWidth hdl = + let ws = map (dim_width . page_dim) (hoodle_pages hdl) + in maximum ws + +getLargestHeight :: Hoodle -> Double +getLargestHeight hdl = + let hs = map (dim_height . page_dim) (hoodle_pages hdl) + in maximum hs + +waitUntil :: (Monad m) => (a -> Bool) -> m a -> m () +waitUntil p act = do + a <- act + if p a + then return () + else waitUntil p act + +-- | for debugging +{- +timeShow :: String -> IO () +timeShow msg = + putStrLn . (msg ++) . (formatTime defaultTimeLocale "%Q") + =<< getCurrentTime +-} diff --git a/src/Hoodle/Util/Verbatim.hs b/src/Hoodle/Util/Verbatim.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Util/Verbatim.hs @@ -0,0 +1,26 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Util.Verbatim +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +module Hoodle.Util.Verbatim where + +import Language.Haskell.TH.Quote + +import Language.Haskell.TH.Lib + +verbatim :: QuasiQuoter +verbatim = QuasiQuoter { quoteExp = litE . stringL + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } +-- , quotePat = litP . stringP +-- } + diff --git a/src/Hoodle/View/Coordinate.hs b/src/Hoodle/View/Coordinate.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/View/Coordinate.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE GADTs, TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.View.Coordinate +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.View.Coordinate where + + +import Control.Applicative +import Control.Category +import Control.Lens +import Control.Monad +import Data.Foldable (toList) +import qualified Data.IntMap as M +import Data.Maybe +import Data.Monoid +import Graphics.UI.Gtk hiding (get,set) +-- from hoodle-platform +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Generic +import Data.Hoodle.BBox +-- from this package +import Hoodle.Device +import Hoodle.Type.Canvas +import Hoodle.Type.PageArrangement +import Hoodle.Type.Alias +-- +import Prelude hiding ((.),id) + +-- | data structure for transformation among screen, canvas, desktop and page coordinates + +data CanvasGeometry = + CanvasGeometry + { screenDim :: ScreenDimension + , canvasDim :: CanvasDimension + , desktopDim :: DesktopDimension + , canvasViewPort :: ViewPortBBox -- ^ in desktop coordinate + , screen2Canvas :: ScreenCoordinate -> CanvasCoordinate + , canvas2Screen :: CanvasCoordinate -> ScreenCoordinate + , canvas2Desktop :: CanvasCoordinate -> DesktopCoordinate + , desktop2Canvas :: DesktopCoordinate -> CanvasCoordinate + , desktop2Page :: DesktopCoordinate -> Maybe (PageNum,PageCoordinate) + , page2Desktop :: (PageNum,PageCoordinate) -> DesktopCoordinate + } + +-- | make a canvas geometry data structure from current status + +makeCanvasGeometry :: PageNum + -> PageArrangement vm + -> DrawingArea + -> IO CanvasGeometry +makeCanvasGeometry cpn arr canvas = do + win <- widgetGetDrawWindow canvas + let cdim@(CanvasDimension (Dim w' h')) = view canvasDimension arr + screen <- widgetGetScreen canvas + (ws,hs) <- (,) <$> (fromIntegral <$> screenGetWidth screen) + <*> (fromIntegral <$> screenGetHeight screen) + (x0,y0) <- return . ((,) <$> fromIntegral.fst <*> fromIntegral.snd ) =<< drawWindowGetOrigin win + let corig = CanvasOrigin (x0,y0) + (deskdim, cvsvbbox, p2d, d2p) = + case arr of + SingleArrangement _ pdim vbbox -> ( DesktopDimension . unPageDimension $ pdim + , vbbox + , DeskCoord . unPageCoord . snd + , \(DeskCoord coord) ->Just (cpn,(PageCoord coord)) ) + ContinuousArrangement _ ddim pfunc vbbox -> + ( ddim, vbbox, makePage2Desktop pfunc, makeDesktop2Page pfunc ) + let s2c = xformScreen2Canvas corig + c2s = xformCanvas2Screen corig + c2d = xformCanvas2Desk cdim cvsvbbox + d2c = xformDesk2Canvas cdim cvsvbbox + return $ CanvasGeometry (ScreenDimension (Dim ws hs)) (CanvasDimension (Dim w' h')) + deskdim cvsvbbox s2c c2s c2d d2c d2p p2d + +-- | +makePage2Desktop :: (PageNum -> Maybe (PageOrigin,PageDimension)) + -> (PageNum,PageCoordinate) + -> DesktopCoordinate +makePage2Desktop pfunc (pnum,PageCoord (x,y)) = + maybe (DeskCoord (-100,-100)) -- temporary + (\(PageOrigin (x0,y0),_) -> DeskCoord (x0+x,y0+y)) + (pfunc pnum) + +-- | +makeDesktop2Page :: (PageNum -> Maybe (PageOrigin,PageDimension)) + -> DesktopCoordinate + -> Maybe (PageNum, PageCoordinate) +makeDesktop2Page pfunc (DeskCoord (x,y)) = + if null matched + then Nothing + else let (pagenum,(PageOrigin (x0,y0),_)) = head matched + in Just (pagenum, PageCoord (x-x0,y-y0)) + where condition (_,(PageOrigin (x0,y0),PageDimension (Dim w h))) = + x >= x0 && x < x0+w && y >= y0 && y < y0+h + matched = filter condition + . catMaybes + . takeWhile isJust + . map ((\x'-> liftM (x',) (pfunc x')) . PageNum) + $ [0..] + + + +-- | +xformScreen2Canvas :: CanvasOrigin -> ScreenCoordinate -> CanvasCoordinate +xformScreen2Canvas (CanvasOrigin (x0,y0)) (ScrCoord (sx,sy)) = CvsCoord (sx-x0,sy-y0) + +-- | + +xformCanvas2Screen :: CanvasOrigin -> CanvasCoordinate -> ScreenCoordinate +xformCanvas2Screen (CanvasOrigin (x0,y0)) (CvsCoord (cx,cy)) = ScrCoord (cx+x0,cy+y0) + +-- | + +xformCanvas2Desk :: CanvasDimension -> ViewPortBBox -> CanvasCoordinate + -> DesktopCoordinate +xformCanvas2Desk (CanvasDimension (Dim w h)) (ViewPortBBox (BBox (x1,y1) (x2,y2))) + (CvsCoord (cx,cy)) = DeskCoord (cx*(x2-x1)/w+x1,cy*(y2-y1)/h+y1) + +-- | + +xformDesk2Canvas :: CanvasDimension -> ViewPortBBox -> DesktopCoordinate + -> CanvasCoordinate +xformDesk2Canvas (CanvasDimension (Dim w h)) (ViewPortBBox (BBox (x1,y1) (x2,y2))) + (DeskCoord (dx,dy)) = CvsCoord ((dx-x1)*w/(x2-x1),(dy-y1)*h/(y2-y1)) + +-- | + +screen2Desktop :: CanvasGeometry -> ScreenCoordinate -> DesktopCoordinate +screen2Desktop geometry = canvas2Desktop geometry . screen2Canvas geometry + +-- | + +desktop2Screen :: CanvasGeometry -> DesktopCoordinate -> ScreenCoordinate +desktop2Screen geometry = canvas2Screen geometry . desktop2Canvas geometry + +-- | + +core2Desktop :: CanvasGeometry -> (Double,Double) -> DesktopCoordinate +core2Desktop geometry = canvas2Desktop geometry . CvsCoord + +-- | + +wacom2Desktop :: CanvasGeometry -> (Double,Double) -> DesktopCoordinate +wacom2Desktop geometry (x,y) = let Dim w h = unScreenDimension (screenDim geometry) + in screen2Desktop geometry . ScrCoord $ (w*x,h*y) + +-- | + +wacom2Canvas :: CanvasGeometry -> (Double,Double) -> CanvasCoordinate +wacom2Canvas geometry (x,y) = let Dim w h = unScreenDimension (screenDim geometry) + in screen2Canvas geometry . ScrCoord $ (w*x,h*y) + +-- | + +device2Desktop :: CanvasGeometry -> PointerCoord -> DesktopCoordinate +device2Desktop geometry (PointerCoord typ x y _z) = + case typ of + Core -> core2Desktop geometry (x,y) + Stylus -> wacom2Desktop geometry (x,y) + Eraser -> wacom2Desktop geometry (x,y) +device2Desktop _geometry NoPointerCoord = error "NoPointerCoordinate device2Desktop" + +-- | + +getPagesInViewPortRange :: CanvasGeometry -> Hoodle EditMode -> [PageNum] +getPagesInViewPortRange geometry hdl = + let ViewPortBBox bbox = canvasViewPort geometry + ivbbox = Intersect (Middle bbox) + pagemap = view gpages hdl + pnums = map PageNum [ 0 .. (length . toList $ pagemap)-1 ] + pgcheck n pg = let Dim w h = view gdimension pg + DeskCoord ul = page2Desktop geometry (PageNum n,PageCoord (0,0)) + DeskCoord lr = page2Desktop geometry (PageNum n,PageCoord (w,h)) + inbbox = Intersect (Middle (BBox ul lr)) + result = ivbbox `mappend` inbbox + in case result of + Intersect Bottom -> False + _ -> True + f (PageNum n) = maybe False (pgcheck n) . M.lookup n $ pagemap + in filter f pnums + +-- | + +getCvsGeomFrmCvsInfo :: (ViewMode a) => + CanvasInfo a -> IO CanvasGeometry +getCvsGeomFrmCvsInfo cinfo = do + let cpn = PageNum . view currentPageNum $ cinfo + canvas = view drawArea cinfo + arr = view (viewInfo.pageArrangement) cinfo + makeCanvasGeometry cpn arr canvas + +-- | Get Canvas Origin in Page Coordinate : Right is successful case, +-- Left is unsuccessful case, then return in DesktopCoordinate + +getCvsOriginInPage :: CanvasGeometry + -> Either DesktopCoordinate (PageNum, PageCoordinate) +getCvsOriginInPage geometry = + let ViewPortBBox (BBox (x0,y0) (_,_)) = canvasViewPort geometry + in case desktop2Page geometry (DeskCoord (x0,y0)) of + Nothing -> Left (DeskCoord (x0,y0)) + Just (pgn,pxy) -> Right (pgn,pxy) + diff --git a/src/Hoodle/View/Draw.hs b/src/Hoodle/View/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/View/Draw.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE GADTs, Rank2Types, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.View.Draw +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.View.Draw where + +import Graphics.UI.Gtk hiding (get) +import Graphics.Rendering.Cairo +import Control.Category ((.)) +import Control.Lens +import Control.Monad (when) + +-- import Data.Label + +import Data.Foldable +import qualified Data.IntMap as M +import Data.Maybe hiding (fromMaybe) +import Data.Monoid +import Data.Sequence +-- from hoodle-platform +import Data.Hoodle.BBox +import Data.Hoodle.Generic +import Data.Hoodle.Predefined +import Data.Hoodle.Select +import Data.Hoodle.Simple (Dimension(..)) +import Graphics.Hoodle.Render.Generic +import Graphics.Hoodle.Render.Highlight +import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest +import Graphics.Hoodle.Render.Util +-- import Graphics.Hoodle.Render.Generic +-- from this package +import Hoodle.Type.Canvas +import Hoodle.Type.Alias +import Hoodle.Util +import Hoodle.Type.PageArrangement +import Hoodle.Type.Predefined +import Hoodle.Type.Enum +import Hoodle.View.Coordinate +-- +import Prelude hiding ((.),id,mapM_,concatMap) + +-- | + +type family DrawingFunction v :: * -> * + +-- | + +newtype SinglePageDraw a = + SinglePageDraw { unSinglePageDraw :: Bool + -> DrawingArea + -> (PageNum, Page a) + -> ViewInfo SinglePage + -> Maybe BBox + -> IO () } + +-- | + +newtype ContPageDraw a = + ContPageDraw + { unContPageDraw :: Bool + -> CanvasInfo ContinuousPage + -> Maybe BBox + -> Hoodle a + -> IO () } + +-- | + +type instance DrawingFunction SinglePage = SinglePageDraw + +-- | + +type instance DrawingFunction ContinuousPage = ContPageDraw + +-- | + +getCanvasViewPort :: CanvasGeometry -> ViewPortBBox +getCanvasViewPort geometry = + let DeskCoord (x0,y0) = canvas2Desktop geometry (CvsCoord (0,0)) + CanvasDimension (Dim w h) = canvasDim geometry + DeskCoord (x1,y1) = canvas2Desktop geometry (CvsCoord (w,h)) + in ViewPortBBox (BBox (x0,y0) (x1,y1)) + +-- | + +getBBoxInPageCoord :: CanvasGeometry -> PageNum -> BBox -> BBox +getBBoxInPageCoord geometry pnum bbox = + let DeskCoord (x0,y0) = page2Desktop geometry (pnum,PageCoord (0,0)) + in moveBBoxByOffset (-x0,-y0) bbox + +-- | + +getViewableBBox :: CanvasGeometry + -> Maybe BBox -- ^ in desktop coordinate + -> IntersectBBox +getViewableBBox geometry mbbox = + let ViewPortBBox vportbbox = getCanvasViewPort geometry + in (fromMaybe mbbox :: IntersectBBox) `mappend` (Intersect (Middle vportbbox)) + +-- | common routine for double buffering + +doubleBufferDraw :: DrawWindow -> CanvasGeometry -> Render () -> Render () + -> IntersectBBox + -> IO () +doubleBufferDraw win geometry _xform rndr (Intersect ibbox) = do + let Dim cw ch = unCanvasDimension . canvasDim $ geometry + mbbox' = case ibbox of + Top -> Just (BBox (0,0) (cw,ch)) + Middle bbox -> Just (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord) bbox) + Bottom -> Nothing + let action = withImageSurface FormatARGB32 (floor cw) (floor ch) $ \tempsurface -> do + renderWith tempsurface $ do + setSourceRGBA 0.5 0.5 0.5 1 + rectangle 0 0 cw ch + fill + rndr + renderWithDrawable win $ do + clipBBox mbbox' + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint + case ibbox of + Top -> action + Middle _ -> action + Bottom -> return () + +-- | + +cairoXform4PageCoordinate :: CanvasGeometry -> PageNum -> Render () +cairoXform4PageCoordinate geometry pnum = do + let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0)) + CvsCoord (x1,y1) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (1,1)) + sx = x1-x0 + sy = y1-y0 + translate x0 y0 + scale sx sy + +-- | + +data PressureMode = NoPressure | Pressure + +-- | + +drawCurvebitGen :: PressureMode + -> DrawingArea + -> CanvasGeometry + -> Double + -> (Double,Double,Double,Double) + -> PageNum + -> ((Double,Double),Double) + -> ((Double,Double),Double) + -> IO () +drawCurvebitGen pmode canvas geometry wdth (r,g,b,a) pnum ((x0,y0),z0) ((x,y),z) = do + win <- widgetGetDrawWindow canvas + renderWithDrawable win $ do + cairoXform4PageCoordinate geometry pnum + setSourceRGBA r g b a + case pmode of + NoPressure -> do + setLineWidth wdth + moveTo x0 y0 + lineTo x y + stroke + Pressure -> do + let wx0 = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z0 + wy0 = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z0 + wx = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z + wy = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z + moveTo (x0-wx0) (y0-wy0) + lineTo (x0+wx0) (y0+wy0) + lineTo (x+wx) (y+wy) + lineTo (x-wx) (y-wy) + fill + +-- | + +drawFuncGen :: em + -> ((PageNum,Page em) -> Maybe BBox -> Render ()) + -> DrawingFunction SinglePage em +drawFuncGen _typ render = SinglePageDraw func + where func isCurrentCvs canvas (pnum,page) vinfo mbbox = do + let arr = view pageArrangement vinfo + geometry <- makeCanvasGeometry pnum arr canvas + win <- widgetGetDrawWindow canvas + let ibboxnew = getViewableBBox geometry mbbox + let mbboxnew = toMaybe ibboxnew + xformfunc = cairoXform4PageCoordinate geometry pnum + renderfunc = do + xformfunc + clipBBox (fmap (flip inflate 1) mbboxnew) + render (pnum,page) mbboxnew + when isCurrentCvs (emphasisCanvasRender ColorBlue geometry) + resetClip + doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + +-- | + +drawFuncSelGen :: ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) + -> ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) + -> DrawingFunction SinglePage SelectMode +drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\x y -> rencont x y >> rensel x y) + +-- | + +emphasisCanvasRender :: PenColor -> CanvasGeometry -> Render () +emphasisCanvasRender pcolor geometry = do + identityMatrix + let CanvasDimension (Dim cw ch) = canvasDim geometry + let (r,g,b,a) = convertPenColorToRGBA pcolor + setSourceRGBA r g b a + setLineWidth 10 + rectangle 0 0 cw ch + stroke + +-- | + +drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) + -> DrawingFunction ContinuousPage EditMode +drawContPageGen render = ContPageDraw func + where func isCurrentCvs cinfo mbbox hdl = do + let arr = view (viewInfo.pageArrangement) cinfo + pnum = PageNum . view currentPageNum $ cinfo + canvas = view drawArea cinfo + geometry <- makeCanvasGeometry pnum arr canvas + let pgs = view gpages hdl + let drawpgs = catMaybes . map f + $ (getPagesInViewPortRange geometry hdl) + where f k = maybe Nothing (\a->Just (k,a)) + . M.lookup (unPageNum k) $ pgs + win <- widgetGetDrawWindow canvas + let ibboxnew = getViewableBBox geometry mbbox + let mbboxnew = toMaybe ibboxnew + xformfunc = cairoXform4PageCoordinate geometry pnum + onepagerender (pn,pg) = do + identityMatrix + cairoXform4PageCoordinate geometry pn + let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew + clipBBox (fmap (flip inflate 1) pgmbbox) + render (pn,pg) pgmbbox + renderfunc = do + xformfunc + mapM_ onepagerender drawpgs + when isCurrentCvs (emphasisCanvasRender ColorRed geometry) + resetClip + doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + + +-- | +cairoBBox :: BBox -> Render () +cairoBBox bbox = do + let (x1,y1) = bbox_upperleft bbox + (x2,y2) = bbox_lowerright bbox + rectangle x1 y1 (x2-x1) (y2-y1) + stroke + +-- | +drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) + -> ((PageNum, Page SelectMode) -> Maybe BBox -> Render ()) + -> DrawingFunction ContinuousPage SelectMode +drawContPageSelGen rendergen rendersel = ContPageDraw func + where func isCurrentCvs cinfo mbbox thdl = do + let arr = view (viewInfo.pageArrangement) cinfo + pnum = PageNum . view currentPageNum $ cinfo + mtpage = view gselSelected thdl + canvas = view drawArea cinfo + geometry <- makeCanvasGeometry pnum arr canvas + let pgs = view gselAll thdl + hdl = GHoodle (view gselTitle thdl) pgs + let drawpgs = catMaybes . map f + $ (getPagesInViewPortRange geometry hdl) + where f k = maybe Nothing (\a->Just (k,a)) + . M.lookup (unPageNum k) $ pgs + win <- widgetGetDrawWindow canvas + let ibboxnew = getViewableBBox geometry mbbox + mbboxnew = toMaybe ibboxnew + xformfunc = cairoXform4PageCoordinate geometry pnum + onepagerender (pn,pg) = do + identityMatrix + cairoXform4PageCoordinate geometry pn + rendergen (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) + selpagerender (pn,pg) = do + identityMatrix + cairoXform4PageCoordinate geometry pn + rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) + renderfunc = do + xformfunc + mapM_ onepagerender drawpgs + maybe (return ()) (\(n,tpage)-> selpagerender (PageNum n,tpage)) mtpage + when isCurrentCvs (emphasisCanvasRender ColorGreen geometry) + resetClip + doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + + +-- | +drawPageClearly :: DrawingFunction SinglePage EditMode +drawPageClearly = drawFuncGen EditMode $ \(_,page) _mbbox -> + cairoRenderOption (RBkgDrawPDF,DrawFull) page + +-- | +drawPageSelClearly :: DrawingFunction SinglePage SelectMode +drawPageSelClearly = drawFuncSelGen rendercontent renderselect + where rendercontent (_pnum,tpg) _mbbox = do + let pg' = hPage2RPage tpg + cairoRenderOption (RBkgDrawPDF,DrawFull) pg' + -- cairoRenderOption (InBBoxOption mbbox) (InBBox pg') + renderselect (_pnum,tpg) mbbox = do + cairoHittedBoxDraw tpg mbbox + +-- | + +drawContHoodleClearly :: DrawingFunction ContinuousPage EditMode +drawContHoodleClearly = + drawContPageGen $ \(_,page) _mbbox -> + cairoRenderOption (RBkgDrawPDF,DrawFull) page + +-- | + +drawContHoodleSelClearly :: DrawingFunction ContinuousPage SelectMode +drawContHoodleSelClearly = drawContPageSelGen renderother renderselect + where renderother (_,page) _mbbox = + cairoRenderOption (RBkgDrawPDF,DrawFull) page + -- cairoRenderOption (InBBoxOption mbbox) (InBBox page) + renderselect (_pnum,tpg) mbbox = + cairoHittedBoxDraw tpg mbbox + +-- | + +drawBuf :: DrawingFunction SinglePage EditMode +drawBuf = drawFuncGen EditMode $ \(_,page) mbbox -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) + +-- | + +drawSelBuf :: DrawingFunction SinglePage SelectMode +drawSelBuf = drawFuncSelGen rencont rensel + where rencont (_pnum,tpg) mbbox = do + let page = hPage2RPage tpg + cairoRenderOption (InBBoxOption mbbox) (InBBox page) + rensel (_pnum,tpg) mbbox = do + cairoHittedBoxDraw tpg mbbox + +-- | +drawContHoodleBuf :: DrawingFunction ContinuousPage EditMode +drawContHoodleBuf = + drawContPageGen $ \(_,page) mbbox -> + cairoRenderOption (InBBoxOption mbbox) (InBBox page) + +-- | +cairoHittedBoxDraw :: Page SelectMode -> Maybe BBox -> Render () +cairoHittedBoxDraw tpg mbbox = do + let layers = view glayers tpg + slayer = view selectedLayer layers + case unTEitherAlterHitted . view gitems $ slayer of + Right alist -> do + clipBBox mbbox + setSourceRGBA 0.0 0.0 1.0 1.0 + let hititms = concatMap unHitted (getB alist) + mapM_ renderSelectedItem hititms -- renderSelectedStroke + let ulbbox = unUnion . mconcat . fmap (Union .Middle . getBBox) + $ hititms + case ulbbox of + Middle bbox -> renderSelectHandle bbox + _ -> return () + resetClip + Left _ -> return () + +-- | + +renderLasso :: Seq (Double,Double) -> Render () +renderLasso lst = do + setLineWidth predefinedLassoWidth + uncurry4 setSourceRGBA predefinedLassoColor + uncurry setDash predefinedLassoDash + case viewl lst of + EmptyL -> return () + x :< xs -> do uncurry moveTo x + mapM_ (uncurry lineTo) xs + stroke + +-- | + +renderBoxSelection :: BBox -> Render () +renderBoxSelection bbox = do + setLineWidth predefinedLassoWidth + uncurry4 setSourceRGBA predefinedLassoColor + uncurry setDash predefinedLassoDash + let (x1,y1) = bbox_upperleft bbox + (x2,y2) = bbox_lowerright bbox + rectangle x1 y1 (x2-x1) (y2-y1) + stroke + +-- | +renderSelectedStroke :: StrokeBBox -> Render () +renderSelectedStroke str = do + setLineWidth 1.5 + setSourceRGBA 0 0 1 1 + renderStrkHltd str + +-- | +renderSelectedItem :: RItem -> Render () +renderSelectedItem itm = do + setLineWidth 1.5 + setSourceRGBA 0 0 1 1 + renderRItemHltd itm + +-- | +renderSelectHandle :: BBox -> Render () +renderSelectHandle bbox = do + setLineWidth predefinedLassoWidth + uncurry4 setSourceRGBA predefinedLassoColor + uncurry setDash predefinedLassoDash + let (x1,y1) = bbox_upperleft bbox + (x2,y2) = bbox_lowerright bbox + rectangle x1 y1 (x2-x1) (y2-y1) + stroke + setSourceRGBA 1 0 0 0.8 + rectangle (x1-5) (y1-5) 10 10 + fill + setSourceRGBA 1 0 0 0.8 + rectangle (x1-5) (y2-5) 10 10 + fill + setSourceRGBA 1 0 0 0.8 + rectangle (x2-5) (y1-5) 10 10 + fill + setSourceRGBA 1 0 0 0.8 + rectangle (x2-5) (y2-5) 10 10 + fill + setSourceRGBA 0.5 0 0.2 0.8 + rectangle (x1-3) (0.5*(y1+y2)-3) 6 6 + fill + setSourceRGBA 0.5 0 0.2 0.8 + rectangle (x2-3) (0.5*(y1+y2)-3) 6 6 + fill + setSourceRGBA 0.5 0 0.2 0.8 + rectangle (0.5*(x1+x2)-3) (y1-3) 6 6 + fill + setSourceRGBA 0.5 0 0.2 0.8 + rectangle (0.5*(x1+x2)-3) (y2-3) 6 6 + fill + diff --git a/template/index.html.st b/template/index.html.st new file mode 100644 --- /dev/null +++ b/template/index.html.st @@ -0,0 +1,8 @@ + + + XOJ file + + + $body$ + +