hoodle-core (empty) → 0.7
raw patch · 87 files changed
+8543/−0 lines, 87 filesdep +Diffdep +TypeComposedep +attoparsecbuild-type:Customsetup-changedbinary-added
Dependencies added: Diff, TypeCompose, attoparsec, base, base64-bytestring, bytestring, cairo, cereal, configurator, containers, coroutine-object, directory, dyre, filepath, gtk, hoodle-builder, hoodle-parser, hoodle-render, hoodle-types, lens, mtl, old-locale, poppler, strict, template-haskell, time, transformers, transformers-free, xournal-parser
Files
- CHANGES +30/−0
- Config.hs +91/−0
- LICENSE +25/−0
- Setup.lhs +9/−0
- csrc/c_initdevice.c +66/−0
- csrc/c_initdevice.h +6/−0
- csrc/template-hsc-gtk2hs.h +17/−0
- hoodle-core.cabal +154/−0
- resource/black.png binary
- resource/blue.png binary
- resource/default-pen.png binary
- resource/eraser.png binary
- resource/fullscreen.png binary
- resource/gray.png binary
- resource/green.png binary
- resource/hand.png binary
- resource/highlighter.png binary
- resource/lasso.png binary
- resource/lightblue.png binary
- resource/lightgreen.png binary
- resource/magenta.png binary
- resource/medium.png binary
- resource/orange.png binary
- resource/pencil.png binary
- resource/rect-select.png binary
- resource/recycled.png binary
- resource/red.png binary
- resource/ruler.png binary
- resource/shapes.png binary
- resource/stretch.png binary
- resource/text-tool.png binary
- resource/thick.png binary
- resource/thin.png binary
- resource/white.png binary
- resource/xournal.png binary
- resource/yellow.png binary
- src/Hoodle/Accessor.hs +221/−0
- src/Hoodle/Config.hs +65/−0
- src/Hoodle/Coroutine.hs +27/−0
- src/Hoodle/Coroutine/Callback.hs +54/−0
- src/Hoodle/Coroutine/Commit.hs +86/−0
- src/Hoodle/Coroutine/Default.hs +315/−0
- src/Hoodle/Coroutine/Draw.hs +181/−0
- src/Hoodle/Coroutine/Eraser.hs +100/−0
- src/Hoodle/Coroutine/EventConnect.hs +78/−0
- src/Hoodle/Coroutine/File.hs +321/−0
- src/Hoodle/Coroutine/Highlighter.hs +27/−0
- src/Hoodle/Coroutine/Layer.hs +144/−0
- src/Hoodle/Coroutine/Mode.hs +146/−0
- src/Hoodle/Coroutine/Page.hs +235/−0
- src/Hoodle/Coroutine/Pen.hs +213/−0
- src/Hoodle/Coroutine/Scroll.hs +127/−0
- src/Hoodle/Coroutine/Select.hs +538/−0
- src/Hoodle/Coroutine/Select/Clipboard.hs +140/−0
- src/Hoodle/Coroutine/Window.hs +182/−0
- src/Hoodle/Device.hsc +189/−0
- src/Hoodle/GUI.hs +101/−0
- src/Hoodle/GUI/Menu.hs +672/−0
- src/Hoodle/ModelAction/Adjustment.hs +72/−0
- src/Hoodle/ModelAction/Clipboard.hs +65/−0
- src/Hoodle/ModelAction/Eraser.hs +29/−0
- src/Hoodle/ModelAction/File.hs +132/−0
- src/Hoodle/ModelAction/Layer.hs +73/−0
- src/Hoodle/ModelAction/Page.hs +214/−0
- src/Hoodle/ModelAction/Pen.hs +80/−0
- src/Hoodle/ModelAction/Select.hs +482/−0
- src/Hoodle/ModelAction/Window.hs +252/−0
- src/Hoodle/Script.hs +43/−0
- src/Hoodle/Script/Coroutine.hs +46/−0
- src/Hoodle/Script/Hook.hs +23/−0
- src/Hoodle/Type.hs +25/−0
- src/Hoodle/Type/Alias.hs +41/−0
- src/Hoodle/Type/Canvas.hs +411/−0
- src/Hoodle/Type/Clipboard.hs +55/−0
- src/Hoodle/Type/Coroutine.hs +109/−0
- src/Hoodle/Type/Enum.hs +75/−0
- src/Hoodle/Type/Event.hs +154/−0
- src/Hoodle/Type/HoodleState.hs +331/−0
- src/Hoodle/Type/PageArrangement.hs +302/−0
- src/Hoodle/Type/Predefined.hs +51/−0
- src/Hoodle/Type/Undo.hs +54/−0
- src/Hoodle/Type/Window.hs +92/−0
- src/Hoodle/Util.hs +78/−0
- src/Hoodle/Util/Verbatim.hs +26/−0
- src/Hoodle/View/Coordinate.hs +211/−0
- src/Hoodle/View/Draw.hs +449/−0
- template/index.html.st +8/−0
+ CHANGES view
@@ -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
+ Config.hs view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,9 @@+#! /usr/bin/env runhaskell+>+> import Distribution.Simple+> import Distribution.PackageDescription+> import Config +> +> main :: IO ()+> main = defaultMainWithHooks myConfigHook+>
+ csrc/c_initdevice.c view
@@ -0,0 +1,66 @@+#include <gtk/gtk.h>+#include <stdio.h>+#include <string.h>++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);+//}
+ csrc/c_initdevice.h view
@@ -0,0 +1,6 @@+#include <gtk/gtk.h>+#include <stdio.h>++void initdevice( int* core, int* stylus, int* eraser, + char* corepointername, char* stylusname, char* erasername ); +
+ csrc/template-hsc-gtk2hs.h view
@@ -0,0 +1,17 @@+#ifndef _TEMPLATE_HSC_GTK2HS_H_+#define _TEMPLATE_HSC_GTK2HS_H_++#include <glib.h>++#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
+ hoodle-core.cabal view
@@ -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 <ianwookim@gmail.com>+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
+ resource/black.png view
binary file changed (absent → 113 bytes)
+ resource/blue.png view
binary file changed (absent → 133 bytes)
+ resource/default-pen.png view
binary file changed (absent → 1485 bytes)
+ resource/eraser.png view
binary file changed (absent → 987 bytes)
+ resource/fullscreen.png view
binary file changed (absent → 836 bytes)
+ resource/gray.png view
binary file changed (absent → 133 bytes)
+ resource/green.png view
binary file changed (absent → 131 bytes)
+ resource/hand.png view
binary file changed (absent → 618 bytes)
+ resource/highlighter.png view
binary file changed (absent → 232 bytes)
+ resource/lasso.png view
binary file changed (absent → 852 bytes)
+ resource/lightblue.png view
binary file changed (absent → 132 bytes)
+ resource/lightgreen.png view
binary file changed (absent → 129 bytes)
+ resource/magenta.png view
binary file changed (absent → 131 bytes)
+ resource/medium.png view
binary file changed (absent → 318 bytes)
+ resource/orange.png view
binary file changed (absent → 131 bytes)
+ resource/pencil.png view
binary file changed (absent → 729 bytes)
+ resource/rect-select.png view
binary file changed (absent → 196 bytes)
+ resource/recycled.png view
binary file changed (absent → 1392 bytes)
+ resource/red.png view
binary file changed (absent → 128 bytes)
+ resource/ruler.png view
binary file changed (absent → 317 bytes)
+ resource/shapes.png view
binary file changed (absent → 294 bytes)
+ resource/stretch.png view
binary file changed (absent → 319 bytes)
+ resource/text-tool.png view
binary file changed (absent → 539 bytes)
+ resource/thick.png view
binary file changed (absent → 389 bytes)
+ resource/thin.png view
binary file changed (absent → 250 bytes)
+ resource/white.png view
binary file changed (absent → 132 bytes)
+ resource/xournal.png view
binary file changed (absent → 2971 bytes)
+ resource/yellow.png view
binary file changed (absent → 131 bytes)
+ src/Hoodle/Accessor.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Accessor +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+-} ++
+ src/Hoodle/Config.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Config +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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)+-}
+ src/Hoodle/Coroutine.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+
+ src/Hoodle/Coroutine/Callback.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Callback+-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 +
+ src/Hoodle/Coroutine/Commit.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Commit +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+ ++++
+ src/Hoodle/Coroutine/Default.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE ScopedTypeVariables, GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Default +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Default where++import Control.Applicative ((<$>))+import Control.Category+import Control.Concurrent +import Control.Lens+import Control.Monad.Reader+import Control.Monad.State +import qualified Data.IntMap as M+import Data.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 +++
+ src/Hoodle/Coroutine/Draw.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE Rank2Types #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Draw +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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)+
+ src/Hoodle/Coroutine/Eraser.hs view
@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Eraser +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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) +
+ src/Hoodle/Coroutine/EventConnect.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.EventConnect +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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)))
+ src/Hoodle/Coroutine/File.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.File +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ()+ +
+ src/Hoodle/Coroutine/Highlighter.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Highlighter +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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
+ src/Hoodle/Coroutine/Layer.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Layer +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ()+
+ src/Hoodle/Coroutine/Mode.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Mode +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+ -}
+ src/Hoodle/Coroutine/Page.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Page +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+++
+ src/Hoodle/Coroutine/Pen.hs view
@@ -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 <ianwookim@gmail.com>+-- 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 + +++
+ src/Hoodle/Coroutine/Scroll.hs view
@@ -0,0 +1,127 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Scroll +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ++++++++
+ src/Hoodle/Coroutine/Select.hs view
@@ -0,0 +1,538 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Select +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ++
+ src/Hoodle/Coroutine/Select/Clipboard.hs view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Select.Clipboard +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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'
+ src/Hoodle/Coroutine/Window.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Window +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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"+ + +
+ src/Hoodle/Device.hsc view
@@ -0,0 +1,189 @@+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Device +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++#include <gtk/gtk.h>+#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)+
+ src/Hoodle/GUI.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.GUI +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ()++++
+ src/Hoodle/GUI/Menu.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE QuasiQuotes #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.GUI.Menu +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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|<ui> + <menubar>+ <menu action="VMA">+ <menuitem action="CONTA" />+ <menuitem action="ONEPAGEA" />+ <separator />+ <menuitem action="FSCRA" />+ <separator />+ </menu>+ </menubar>+</ui>|]++-- | ++uiDecl :: String +uiDecl = [verbatim|<ui> + <menubar>+ <menu action="FMA">+ <menuitem action="NEWA" />+ <menuitem action="ANNPDFA" /> + <menuitem action="LDIMGA" />+ <menuitem action="OPENA" /> + <menuitem action="SAVEA" /> + <menuitem action="SAVEASA" /> + <menuitem action="RELOADA" />+ <separator /> + <menuitem action="RECENTA" /> + <separator /> + <menuitem action="PRINTA" /> + <menuitem action="EXPORTA" />+ <separator /> + <menuitem action="QUITA" />+ </menu>+ <menu action="EMA">+ <menuitem action="UNDOA" />+ <menuitem action="REDOA" /> + <separator />+ <menuitem action="CUTA" /> + <menuitem action="COPYA" /> + <menuitem action="PASTEA" /> + <menuitem action="DELETEA" />+ <separator />+ <menuitem action="NETCOPYA" />+ <menuitem action="NETPASTEA" />+ </menu>+ <menu action="VMA">+ <menuitem action="CONTA" />+ <menuitem action="ONEPAGEA" />+ <separator />+ <menuitem action="FSCRA" />+ <separator />+ <menu action="ZOOMA" >+ <menuitem action="ZMINA" />+ <menuitem action="ZMOUTA" /> + <menuitem action="NRMSIZEA" /> + <menuitem action="PGWDTHA" /> + <menuitem action="PGHEIGHTA" />+ <menuitem action="SETZMA" /> + </menu>+ <separator />+ <menuitem action="FSTPAGEA" />+ <menuitem action="PRVPAGEA" />+ <menuitem action="NXTPAGEA" />+ <menuitem action="LSTPAGEA" />+ <separator />+ <menuitem action="SHWLAYERA" />+ <menuitem action="HIDLAYERA" />+ <separator />+ <menuitem action="HSPLITA" />+ <menuitem action="VSPLITA" />+ <menuitem action="DELCVSA" />+ </menu>+ <menu action="JMA">+ <menuitem action="NEWPGBA" />+ <menuitem action="NEWPGAA" />+ <menuitem action="NEWPGEA" />+ <menuitem action="DELPGA" /> + <separator />+ <menuitem action="NEWLYRA" />+ <menuitem action="NEXTLAYERA" />+ <menuitem action="PREVLAYERA" />+ <menuitem action="GOTOLAYERA" />+ <menuitem action="DELLYRA" /> + <separator />+ <menuitem action="PPSIZEA" />+ <menuitem action="PPCLRA" />+ <menuitem action="PPSTYA" />+ <menuitem action="APALLPGA" />+ <separator />+ <menuitem action="LDBKGA" />+ <menuitem action="BKGSCRSHTA" />+ <separator />+ <menuitem action="DEFPPA" /> + <menuitem action="SETDEFPPA" /> + </menu>+ <menu action="TMA">+ <menuitem action="PENA" />+ <menuitem action="ERASERA" />+ <menuitem action="HIGHLTA" />+ <menuitem action="TEXTA" /> + <separator />+ <menuitem action="SHPRECA" />+ <menuitem action="RULERA" /> + <separator />+ <menuitem action="SELREGNA" />+ <menuitem action="SELRECTA" />+ <menuitem action="VERTSPA" />+ <menuitem action="HANDA" />+ <separator />+ <menu action="CLRA"> + <menuitem action="BLACKA" /> + <menuitem action="BLUEA" /> + <menuitem action="REDA" /> + <menuitem action="GREENA" /> + <menuitem action="GRAYA" /> + <menuitem action="LIGHTBLUEA" /> + <menuitem action="LIGHTGREENA" /> + <menuitem action="MAGENTAA" />+ <menuitem action="ORANGEA" />+ <menuitem action="YELLOWA" />+ <menuitem action="WHITEA" />+ </menu> + <menu action="PENOPTA"> + <menuitem action="PENVERYFINEA" /> + <menuitem action="PENFINEA" /> + <menuitem action="PENMEDIUMA" /> + <menuitem action="PENTHICKA" /> + <menuitem action="PENVERYTHICKA" /> + <menuitem action="PENULTRATHICKA" /> + </menu>+ <menuitem action="ERASROPTA" /> + <menuitem action="HILTROPTA" /> + <menuitem action="TXTFNTA" /> + <separator />+ <menuitem action="DEFPENA" /> + <menuitem action="DEFERSRA" /> + <menuitem action="DEFHILTRA" /> + <menuitem action="DEFTXTA" />+ <menuitem action="SETDEFOPTA" /> + </menu>+ <menu action="OMA">+ <menuitem action="UXINPUTA" />+ <menuitem action="DCRDCOREA" /> + <menuitem action="ERSRTIPA" /> + <menuitem action="PRESSRSENSA" /> + <menuitem action="PGHILTA" /> + <menuitem action="MLTPGVWA" /> + <menuitem action="MLTPGA" /> + <menuitem action="BTN2MAPA" /> + <menuitem action="BTN3MAPA" /> + <separator />+ <menuitem action="ANTIALIASBMPA" /> + <menuitem action="PRGRSBKGA" /> + <menuitem action="PRNTPPRULEA" /> + <menuitem action="LFTHNDSCRBRA" /> + <menuitem action="SHRTNMENUA" /> + <separator />+ <menuitem action="AUTOSAVEPREFA" /> + <menuitem action="SAVEPREFA" />+ <menuitem action="RELAUNCHA" />+ </menu>+ <menu action="HMA">+ <menuitem action="ABOUTA" />+ </menu>+ </menubar>+ <toolbar name="toolbar1" > + <toolitem action="SAVEA" />+ <toolitem action="NEWA" />+ <toolitem action="OPENA" />+ <separator />+ <toolitem action="CUTA" />+ <toolitem action="COPYA" />+ <toolitem action="PASTEA" />+ <separator /> + <toolitem action="UNDOA" /> + <toolitem action="REDOA" /> + <separator /> + <toolitem action="FSTPAGEA" />+ <toolitem action="PRVPAGEA" />+ <toolitem action="NXTPAGEA" />+ <toolitem action="LSTPAGEA" />+ <separator />+ <toolitem action="ZMOUTA" /> + <toolitem action="NRMSIZEA" /> + <toolitem action="ZMINA" />+ <toolitem action="PGWDTHA" /> + <toolitem action="SETZMA" />+ <toolitem action="FSCRA" />+ </toolbar>+ <toolbar name="toolbar2" > + <toolitem action="PENA" />+ <toolitem action="ERASERA" /> + <toolitem action="HIGHLTA" /> + <toolitem action="TEXTA" /> + <separator /> + <!-- <toolitem action="DEFAULTA" /> --> + <!-- <toolitem action="DEFPENA" /> --> + <!-- <toolitem action="SHPRECA" /> --> + <!-- <toolitem action="RULERA" /> --> + <!-- <separator /> -->+ <toolitem action="SELREGNA" /> + <toolitem action="SELRECTA" /> + <toolitem action="VERTSPA" /> + <toolitem action="HANDA" /> + <separator /> + <toolitem action="PENFINEA" /> + <toolitem action="PENMEDIUMA" /> + <toolitem action="PENTHICKA" /> + <separator />+ <toolitem action="BLACKA" /> + <toolitem action="BLUEA" /> + <toolitem action="REDA" /> + <toolitem action="GREENA" /> + <toolitem action="GRAYA" /> + <toolitem action="LIGHTBLUEA" /> + <toolitem action="LIGHTGREENA" /> + <toolitem action="MAGENTAA" /> + <toolitem action="ORANGEA" /> + <toolitem action="YELLOWA" /> + <toolitem action="WHITEA" /> + </toolbar>+</ui>+|]++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 "<control>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"
+ src/Hoodle/ModelAction/Adjustment.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Adjustment +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+ ++
+ src/Hoodle/ModelAction/Clipboard.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Clipboard +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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))
+ src/Hoodle/ModelAction/Eraser.hs view
@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Eraser +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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
+ src/Hoodle/ModelAction/File.hs view
@@ -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 <ianwookim@gmail.com>+-- 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
+ src/Hoodle/ModelAction/Layer.hs view
@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Layer +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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++
+ src/Hoodle/ModelAction/Page.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Page +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+
+ src/Hoodle/ModelAction/Pen.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Pen +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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)+
+ src/Hoodle/ModelAction/Select.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Select +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 + | ax<bx && ay>by = atan ((ay-by)/(ax-bx)) + pi + | ax<bx && ay<=by = atan ((ay-by)/(ax-bx)) - pi+ | otherwise = atan ((ay-by)/(ax-bx)) + theta2 | cx==bx && cy>by = pi/2.0 + | cx==bx && cy<=by = -pi/2.0 + | cx<bx && cy>by = atan ((cy-by)/(cx-bx)) +pi+ | cx<bx && cy<=by = atan ((cy-by)/(cx-bx)) - pi+ | otherwise = atan ((cy-by)/(cx-bx))+ dtheta = theta2 - theta1 + result | dtheta > 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)) +
+ src/Hoodle/ModelAction/Window.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Window +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 -}
+ src/Hoodle/Script.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Script+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 + +
+ src/Hoodle/Script/Coroutine.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Script.Coroutine+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ++
+ src/Hoodle/Script/Hook.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Script.Hook+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ())+ } ++
+ src/Hoodle/Type.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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
+ src/Hoodle/Type/Alias.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE EmptyDataDecls, TypeFamilies, RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Alias+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ++
+ src/Hoodle/Type/Canvas.hs view
@@ -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 <ianwookim@gmail.com>+-- 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+
+ src/Hoodle/Type/Clipboard.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Clipboard +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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
+ src/Hoodle/Type/Coroutine.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Coroutine +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 ()))++++
+ src/Hoodle/Type/Enum.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Enum +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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)+
+ src/Hoodle/Type/Event.hs view
@@ -0,0 +1,154 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Event +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+
+ src/Hoodle/Type/HoodleState.hs view
@@ -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 <ianwookim@gmail.com>+-- 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 ++++
+ src/Hoodle/Type/PageArrangement.hs view
@@ -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 <ianwookim@gmail.com>+-- 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)+-}++
+ src/Hoodle/Type/Predefined.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Predefined+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+
+ src/Hoodle/Type/Undo.hs view
@@ -0,0 +1,54 @@++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Undo +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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
+ src/Hoodle/Type/Window.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Type.Window +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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"+
+ src/Hoodle/Util.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Util +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 +-}
+ src/Hoodle/Util/Verbatim.hs view
@@ -0,0 +1,26 @@++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Util.Verbatim +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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+-- } +
+ src/Hoodle/View/Coordinate.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE GADTs, TupleSections #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.View.Coordinate+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- 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)+
+ src/Hoodle/View/Draw.hs view
@@ -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 <ianwookim@gmail.com>+-- 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+
+ template/index.html.st view
@@ -0,0 +1,8 @@+<html>+ <head>+ <title> XOJ file </title>+ </head>+ <body>+ $body$+ </body>+</html>