packages feed

hxournal (empty) → 0.5

raw patch · 75 files changed

+3679/−0 lines, 75 filesdep +basedep +blaze-builderdep +bytestringsetup-changedbinary-added

Dependencies added: base, blaze-builder, bytestring, cairo, cmdargs, containers, directory, double-conversion, fclabels, filepath, gtk, hxournal, monad-coroutine, mtl, strict, template-haskell, transformers, xournal-parser, xournal-render

Files

+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2011, 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,10 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> import Distribution.PackageDescription+> --import System.Process+> main = defaultMain+> --main = defaultMainWithHooks testUserHooks+> --testUserHooks = simpleUserHooks { +>  --   preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo+>   --  }
+ csrc/c_initdevice.c view
@@ -0,0 +1,58 @@+#include <gtk/gtk.h>+#include <stdio.h>+#include <string.h>++void initdevice( int* core, int* stylus, int* eraser )+{+  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("   yeah this is xinput device %s \n", device -> name);+      if( !strcmp (device->name, "stylus") )+        (*stylus) = (int) device; +      if( !strcmp (device->name, "eraser") )+        (*eraser) = (int) device;+    } +    else { +      if( !strcmp (device->name, "Core Pointer") )+        (*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*, int*, int* );  ++//void extEventCanvas( void* );
+ exe/hxournal.hs view
@@ -0,0 +1,13 @@+module Main where++import System.Console.CmdArgs++import Application.HXournal.ProgType+import Application.HXournal.Command++main :: IO () +main = do +  putStrLn "hxournal"+  param <- cmdArgs mode++  commandLineProcess param
+ hxournal.cabal view
@@ -0,0 +1,97 @@+Name:		hxournal+Version:	0.5+Synopsis:	A pen notetaking program written in haskell +Description: 	notetaking program written in haskell and gtk2hs+License: 	BSD3+License-file:	LICENSE+Author:		Ian-Woo Kim+Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com>+Build-Type: 	Simple+Cabal-Version:  >= 1.8+data-files:     template/*.html.st+                resource/*.png+++Executable hxournal+  Main-is: hxournal.hs+  hs-source-dirs: exe+  ghc-options: 	-Wall -O2 -threaded -funbox-strict-fields -fno-warn-unused-do-bind+  ghc-prof-options: -caf-all -auto-all+  Build-Depends: +                 base>4, +                 cmdargs >= 0.7 && <= 0.10, +                 hxournal == 0.5++Library+  hs-source-dirs: lib+  ghc-options: 	-Wall -O2 -threaded -funbox-strict-fields -fno-warn-unused-do-bind+  ghc-prof-options: -caf-all -auto-all+  Build-Depends:   +                     base == 4.*, +                     mtl == 2.*,+                     directory == 1.*,+                     filepath == 1.*, +                     strict == 0.3.*,+                     gtk == 0.12.*, +                     cairo == 0.12.*,  +                     monad-coroutine == 0.7.*, +                     transformers == 0.2.*,+                     xournal-parser == 0.2.*,+                     xournal-render == 0.2.*,+                     containers == 0.4.*,+                     template-haskell == 2.*,+                     blaze-builder == 0.3.*, +                     bytestring == 0.9.*, +                     double-conversion == 0.2.*,+                     fclabels == 1.0.*,+                     cmdargs >= 0.7 && <= 0.10+  Exposed-Modules: +                   Application.HXournal.ProgType+                   Application.HXournal.Job+                   Application.HXournal.Command +                   Application.HXournal.Type+                   Application.HXournal.Type.Event +                   Application.HXournal.Type.Enum+                   Application.HXournal.Type.Clipboard+                   Application.HXournal.Type.Canvas+                   Application.HXournal.Type.Coroutine+                   Application.HXournal.Type.XournalState+                   Application.HXournal.Type.Window+                   Application.HXournal.ModelAction.Adjustment+                   Application.HXournal.ModelAction.Pen +                   Application.HXournal.ModelAction.Page+                   Application.HXournal.ModelAction.Eraser+                   Application.HXournal.ModelAction.Select+                   Application.HXournal.ModelAction.File+                   Application.HXournal.ModelAction.Window+                   Application.HXournal.Coroutine.Callback+                   Application.HXournal.GUI+                   Application.HXournal.GUI.Menu+                   Application.HXournal.Coroutine+                   Application.HXournal.Coroutine.Draw+                   Application.HXournal.Coroutine.EventConnect+                   Application.HXournal.Coroutine.Default+                   Application.HXournal.Coroutine.Pen+                   Application.HXournal.Coroutine.Eraser+                   Application.HXournal.Coroutine.Highlighter+                   Application.HXournal.Coroutine.Scroll+                   Application.HXournal.Coroutine.Page+                   Application.HXournal.Coroutine.Select+                   Application.HXournal.Coroutine.File+                   Application.HXournal.Coroutine.Mode+                   Application.HXournal.Coroutine.Window+                   Application.HXournal.Util+                   Application.HXournal.Util.Verbatim +                   Application.HXournal.Draw+                   Application.HXournal.Device+                   Application.HXournal.Builder +                   Application.HXournal.Accessor+  Other-Modules: +                   Paths_hxournal+  c-sources: +                   csrc/c_initdevice.c+  include-dirs:    csrc+  install-includes: +                   c_initdevice.h++
+ lib/Application/HXournal/Accessor.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeOperators #-}++module Application.HXournal.Accessor where++import Application.HXournal.Type+import Application.HXournal.Draw +import Application.HXournal.ModelAction.Page+import Text.Xournal.Type+import Graphics.Xournal.Type +import Control.Applicative+import Control.Monad+import qualified Control.Monad.State as St+import Control.Monad.Trans+import Control.Category+import qualified Data.IntMap as M+import Data.Label+import Prelude hiding ((.),id)+import Graphics.UI.Gtk hiding (get,set)++getSt :: Iteratee MyEvent XournalStateIO HXournalState+getSt = lift St.get++putSt :: HXournalState -> Iteratee MyEvent XournalStateIO ()+putSt = lift . St.put+++adjustments :: CanvasInfo :-> (Adjustment,Adjustment) +adjustments = Lens $ (,) <$> (fst `for` horizAdjustment)+                         <*> (snd `for` vertAdjustment)++getPenType :: Iteratee MyEvent XournalStateIO PenType+getPenType = get (penType.penInfo) <$> lift (St.get)+      +getAllStrokeBBoxInCurrentPage :: Iteratee MyEvent XournalStateIO [StrokeBBox]+getAllStrokeBBoxInCurrentPage = do +  xstate <- getSt +  let currCvsInfo  = getCurrentCanvasInfo xstate +  let -- pagenum = get currentPageNum currCvsInfo+      pagebbox = getPage currCvsInfo+      strs = do +        l <- pageLayers pagebbox +        s <- layerbbox_strokes l+        return s +  return strs +      +      +updateCanvasInfo :: CanvasInfo -> HXournalState -> HXournalState+updateCanvasInfo cinfo xstate = +  let cid = get canvasId cinfo+      cmap = get canvasInfoMap xstate+      cmap' = M.adjust (const cinfo) cid cmap +      xstate' = set canvasInfoMap cmap' xstate+  in xstate' + +otherCanvas :: HXournalState -> [Int] +otherCanvas = M.keys . get canvasInfoMap ++changeCurrentCanvasId :: CanvasId -> Iteratee MyEvent XournalStateIO HXournalState+changeCurrentCanvasId cid = do xstate1 <- getSt +                               let xstate = set currentCanvas cid xstate1+                               putSt xstate+                               return xstate+                               +getCanvasInfo :: CanvasId -> HXournalState -> CanvasInfo +getCanvasInfo cid xstate = +  let cinfoMap = get canvasInfoMap xstate+      maybeCvs = M.lookup cid cinfoMap+  in  case maybeCvs of +        Nothing -> error $ "no canvas with id = " ++ show cid +        Just cvsInfo -> cvsInfo++getCurrentCanvasInfo :: HXournalState -> CanvasInfo +getCurrentCanvasInfo xstate = getCanvasInfo (get currentCanvas xstate) xstate+      ++getCanvasGeometry :: CanvasInfo -> Iteratee MyEvent XournalStateIO CanvasPageGeometry+getCanvasGeometry cinfo = do +    let canvas = get drawArea cinfo+        page = getPage cinfo+        -- zmode = get (zoomMode.viewInfo) cinfo+        (x0,y0) = get (viewPortOrigin.viewInfo) cinfo+    liftIO (getCanvasPageGeometry canvas page (x0,y0))
+ lib/Application/HXournal/Builder.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++module Application.HXournal.Builder where++import Text.Xournal.Type+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8 (fromChar)+import Data.Double.Conversion.ByteString +import Data.Monoid+import Data.Strict.Tuple++infixl 4 <>++(<>) :: Monoid a => a -> a -> a +(<>) = mappend +++builder :: Xournal -> L.ByteString+builder = toLazyByteString . fromXournal++fromXournal :: Xournal -> Builder +fromXournal xoj = fromByteString "<?xml version=\"1.0\" standalone=\"no\"?>\n<xournal version=\"0.4.2.1\">\n"+                  <> fromTitle (xoj_title xoj) <> mconcat (map fromPage (xoj_pages xoj))+                  <> fromByteString "</xournal>\n"+  +fromTitle :: S.ByteString -> Builder+fromTitle title = fromByteString "<title>"+                  <> fromByteString title+                  <> fromByteString "</title>\n"++  +fromPage :: Page -> Builder +fromPage page = fromByteString "<page width=\""+                <> fromByteString (toFixed 2 w)+                <> fromByteString "\" height=\""+                <> fromByteString (toFixed 2 h)+                <> fromByteString "\">\n"   +                <> fromBackground (page_bkg page)+                <> mconcat (map fromLayer (page_layers page))+                <> fromByteString "</page>\n"+  where Dim w h = page_dim page+  +fromBackground :: Background -> Builder +fromBackground bkg = fromByteString "<background type=\""+                     <> fromByteString (bkg_type bkg)+                     <> fromByteString "\" color=\""+                     <> fromByteString (bkg_color bkg)+                     <> fromByteString "\" style=\""+                     <> fromByteString (bkg_style bkg)+                     <> fromByteString "\"/>\n"+                     ++fromLayer :: Layer -> Builder+fromLayer layer = fromByteString "<layer>\n"+                  <> mconcat (map fromStroke (layer_strokes layer))+                  <> fromByteString "</layer>\n"++fromStroke :: Stroke -> Builder+fromStroke stroke = fromByteString "<stroke tool=\""+                    <> fromByteString (stroke_tool stroke)+                    <> fromByteString "\" color=\""+                    <> fromByteString (stroke_color stroke)+                    <> fromByteString "\" width=\""+                    <> fromByteString (toFixed 2 (stroke_width stroke))+                    <> fromByteString "\">\n"+                    <> mconcat (map fromCoord (stroke_data stroke))+                    <> fromByteString "\n</stroke>\n"++fromCoord :: Pair Double Double -> Builder +fromCoord (x :!: y) = fromByteString (toFixed 2 x) +                      <> fromChar ' ' +                      <> fromByteString (toFixed 2 y) +                      <> fromChar ' '
+ lib/Application/HXournal/Command.hs view
@@ -0,0 +1,10 @@+module Application.HXournal.Command where++import Application.HXournal.ProgType+import Application.HXournal.Job++commandLineProcess :: Hxournal -> IO ()+commandLineProcess (Test mfname) = do +  putStrLn "test called"+  startJob mfname+
+ lib/Application/HXournal/Coroutine.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}++module Application.HXournal.Coroutine +( module Application.HXournal.Coroutine.EventConnect+, module Application.HXournal.Coroutine.Default+, module Application.HXournal.Coroutine.Pen+, module Application.HXournal.Coroutine.Eraser+, module Application.HXournal.Coroutine.Highlighter+) where ++import Application.HXournal.Coroutine.EventConnect+import Application.HXournal.Coroutine.Default+import Application.HXournal.Coroutine.Pen+import Application.HXournal.Coroutine.Eraser+import Application.HXournal.Coroutine.Highlighter+
+ lib/Application/HXournal/Coroutine/Callback.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts #-}++module Application.HXournal.Coroutine.Callback where++import Control.Monad.Coroutine +import Control.Monad.State+import Control.Monad.Coroutine.SuspensionFunctors+import Data.IORef+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Event ++dummycallback :: MyEvent -> IO ()+dummycallback = const (return ())++bouncecallback :: TRef -> SRef -> MyEvent -> IO () +bouncecallback tref sref input = do +  Await cont <- readIORef tref +  st <- readIORef sref+  (nr,st') <- runStateT (resume (cont input)) st +  case nr of  +    Left  naw -> do writeIORef tref naw +                    writeIORef sref st'+    Right val -> do putStrLn $ show val +                    writeIORef tref (Await (\_ -> return ()))+                    writeIORef sref st'+  return ()  +
+ lib/Application/HXournal/Coroutine/Default.hs view
@@ -0,0 +1,202 @@+module Application.HXournal.Coroutine.Default where++import Graphics.UI.Gtk hiding (get,set)++import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Clipboard+import Application.HXournal.Draw+import Application.HXournal.Accessor++import Application.HXournal.Coroutine.Callback+import Application.HXournal.Coroutine.Draw+import Application.HXournal.Coroutine.Pen+import Application.HXournal.Coroutine.Eraser+import Application.HXournal.Coroutine.Highlighter+import Application.HXournal.Coroutine.Scroll+import Application.HXournal.Coroutine.Page+import Application.HXournal.Coroutine.Select+import Application.HXournal.Coroutine.File+import Application.HXournal.Coroutine.Mode+import Application.HXournal.Coroutine.Window++import Application.HXournal.ModelAction.Adjustment+import Application.HXournal.ModelAction.Page+import Application.HXournal.ModelAction.Window +import Application.HXournal.Type.Window +import Application.HXournal.Device+import Control.Monad.Coroutine+import Control.Monad.Coroutine.SuspensionFunctors+import qualified Control.Monad.State as St +import Control.Monad.Trans+import qualified Data.IntMap as M+import Data.Maybe+import Control.Category+import Data.Label+import Prelude hiding ((.), id)+import Data.IORef+import Graphics.Xournal.Type.Map+import Graphics.Xournal.Type.Select++guiProcess :: Iteratee MyEvent XournalStateIO () +guiProcess = do +  initialize+  changePage (const 0)+  xstate <- getSt+  let cinfoMap  = get canvasInfoMap xstate+      assocs = M.toList cinfoMap +      f (cid,cinfo) = do let canvas = get drawArea cinfo+                         (w',h') <- liftIO $ widgetGetSize canvas+                         defaultEventProcess (CanvasConfigure cid+                                                (fromIntegral w') +                                                (fromIntegral h')) +  mapM_ f assocs+  sequence_ (repeat dispatchMode)++initCoroutine :: DeviceList -> Window -> IO (TRef,SRef)+initCoroutine devlst window = do +  let st0 = (emptyHXournalState :: HXournalState)+  sref <- newIORef st0+  tref <- newIORef (undefined :: SusAwait)+  let st1 = set deviceList devlst  +            . set rootOfRootWindow window +            . set callBack (bouncecallback tref sref) $ st0 +  initcvs <- initCanvasInfo st1 1 +  let initcmap = M.insert (get canvasId initcvs) initcvs M.empty+  let startingXstate = set currentCanvas (get canvasId initcvs)+                       . set canvasInfoMap initcmap +                       . set frameState (Node 1)+                       $ st1+  (r,st') <- St.runStateT (resume guiProcess) startingXstate +  writeIORef sref st' +  case r of +    Left aw -> do +      writeIORef tref aw +    Right _ -> error "what?"+  return (tref,sref)++initialize :: Iteratee MyEvent XournalStateIO ()+initialize = do ev <- await +                liftIO $ putStrLn $ show ev +                case ev of +                  Initialized -> return () +                  _ -> initialize+++dispatchMode :: Iteratee MyEvent XournalStateIO ()+dispatchMode = do +  xojstate <- return . get xournalstate =<< lift St.get+  case xojstate of +    ViewAppendState _ -> viewAppendMode+    SelectState _ -> selectMode++viewAppendMode :: Iteratee MyEvent XournalStateIO ()+viewAppendMode = do +  r1 <- await +  case r1 of +    PenDown cid pcoord -> do +      ptype <- getPenType +      case ptype of +        PenWork         -> penStart cid pcoord +        EraserWork      -> eraserStart cid pcoord +        HighlighterWork -> highlighterStart pcoord+        _ -> return () +    _ -> defaultEventProcess r1++selectMode :: Iteratee MyEvent XournalStateIO ()+selectMode = do +  r1 <- await +  case r1 of +    PenDown cid pcoord -> do +      ptype <- return . get (selectType.selectInfo) =<< lift St.get +      case ptype of +        SelectRectangleWork -> selectRectStart cid pcoord +        _ -> return () +    PenColorChanged c -> selectPenColorChanged c+    PenWidthChanged w -> selectPenWidthChanged w+    _ -> defaultEventProcess r1++++defaultEventProcess :: MyEvent -> Iteratee MyEvent XournalStateIO () +defaultEventProcess (UpdateCanvas cid) = invalidate cid   +defaultEventProcess (Menu m) = menuEventProcess m+defaultEventProcess (HScrollBarMoved cid v) = do +    xstate <- getSt +    let cinfoMap = get canvasInfoMap xstate+        maybeCvs = M.lookup cid cinfoMap +    case maybeCvs of +      Nothing -> return ()+      Just cvsInfo -> do +        let vm_orig = get (viewPortOrigin.viewInfo) cvsInfo+        let cvsInfo' = set (viewPortOrigin.viewInfo) (v,snd vm_orig) +                         $ cvsInfo+            xstate' = set currentCanvas cid +                    . updateCanvasInfo cvsInfo' +                    $ xstate+        lift . St.put $ xstate'+        invalidate cid+defaultEventProcess (VScrollBarMoved cid v) = do +    xstate <- lift St.get +    let cinfoMap = get canvasInfoMap xstate+        cvsInfo = case M.lookup cid cinfoMap of +                     Nothing -> error "No such canvas in defaultEventProcess" +                     Just cvs -> cvs+    let vm_orig = get (viewPortOrigin.viewInfo) cvsInfo+    let cvsInfo' = set (viewPortOrigin.viewInfo) (fst vm_orig,v)+                   $ cvsInfo +        xstate' = set currentCanvas cid +                  . updateCanvasInfo cvsInfo' $ xstate+    lift . St.put $ xstate'+    invalidate cid+defaultEventProcess (VScrollBarStart cid _v) = vscrollStart cid +defaultEventProcess (CanvasConfigure cid w' h') = do +    xstate <- getSt+    let cinfoMap = get canvasInfoMap xstate+    case M.lookup cid cinfoMap of +      Nothing -> return () +      Just cvsInfo -> do +        let canvas = get drawArea cvsInfo+        let page = getPage cvsInfo +            (w,h) = get (pageDimension.viewInfo) cvsInfo+            zmode = get (zoomMode.viewInfo) cvsInfo+        cpg <- liftIO (getCanvasPageGeometry canvas page (0,0))+        let factor = getRatioFromPageToCanvas cpg zmode+            (hadj,vadj) = get adjustments cvsInfo+        liftIO $ setAdjustments (hadj,vadj) (w,h) (0,0) (0,0)+                                (w'/factor,h'/factor)+        invalidate cid+defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode+defaultEventProcess ToSelectMode = modeChange ToSelectMode +defaultEventProcess _ = return ()++++menuEventProcess :: MenuEvent -> Iteratee MyEvent XournalStateIO ()+menuEventProcess MenuQuit = liftIO $ mainQuit+menuEventProcess MenuPreviousPage = changePage (\x->x-1)+menuEventProcess MenuNextPage =  changePage (+1)+menuEventProcess MenuFirstPage = changePage (const 0)+menuEventProcess MenuLastPage = do +  xstate <- getSt+  let totalnumofpages = case get xournalstate xstate of +                          ViewAppendState xoj ->  M.size . xbm_pages $ xoj+                          SelectState txoj    -> M.size . tx_pages $ txoj+  changePage (const (totalnumofpages-1))+menuEventProcess MenuNew  = fileNew +menuEventProcess MenuOpen = fileOpen+menuEventProcess MenuSave = fileSave +menuEventProcess MenuSaveAs = fileSaveAs+menuEventProcess MenuCut = cutSelection+menuEventProcess MenuCopy = copySelection+menuEventProcess MenuPaste = pasteToSelection+menuEventProcess MenuDelete = deleteSelection+menuEventProcess MenuNormalSize = pageZoomChange Original  +menuEventProcess MenuPageWidth = pageZoomChange FitWidth +menuEventProcess MenuPageHeight = pageZoomChange FitHeight+menuEventProcess MenuHSplit = eitherSplit SplitHorizontal+menuEventProcess MenuVSplit = eitherSplit SplitVertical+menuEventProcess MenuDelCanvas = deleteCanvas+menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m
+ lib/Application/HXournal/Coroutine/Draw.hs view
@@ -0,0 +1,92 @@+module Application.HXournal.Coroutine.Draw where++import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Draw+import Application.HXournal.Accessor+import Graphics.Xournal.Type+import Control.Applicative +import Control.Monad+import Control.Monad.Trans+import qualified Control.Monad.State as St+import qualified Data.IntMap as M+import Data.Label+import Prelude hiding ((.),id)++invalidateSelSingle :: CanvasId -> Maybe BBox +                       -> PageDrawF+                       -> PageDrawFSel +                       -> Iteratee MyEvent XournalStateIO ()+invalidateSelSingle cid mbbox drawf drawfsel = do+  xstate <- lift St.get  +  let  maybeCvs = M.lookup cid (get canvasInfoMap xstate)+  case maybeCvs of +    Nothing -> return ()+    Just cvsInfo -> do +      case get currentPage cvsInfo of +        Left page ->  liftIO (drawf <$> get drawArea +                                    <*> pure page +                                    <*> get viewInfo +                                    <*> pure mbbox+                                    $ cvsInfo )+        Right tpage -> liftIO (drawfsel <$> get drawArea +                                        <*> pure tpage+                                        <*> get viewInfo+                                        <*> pure mbbox+                                        $ cvsInfo )++invalidateGenSingle :: CanvasId -> Maybe BBox -> PageDrawF+                    -> Iteratee MyEvent XournalStateIO ()+invalidateGenSingle cid mbbox drawf = do+  xstate <- lift St.get  +  let  maybeCvs = M.lookup cid (get canvasInfoMap xstate)+  case maybeCvs of +    Nothing -> return ()+    Just cvsInfo -> do +      let page = case get currentPage cvsInfo of+                   Right _ -> error "no invalidateGenSingle implementation yet"+                   Left pg -> pg+      liftIO (drawf <$> get drawArea +                    <*> pure page +                    <*> get viewInfo +                    <*> pure mbbox+                    $ cvsInfo )+++invalidateGen  :: [CanvasId] -> Maybe BBox -> PageDrawF+               -> Iteratee MyEvent XournalStateIO ()+invalidateGen cids mbbox drawf = do                +  forM_ cids $ \x -> invalidateSelSingle x mbbox drawf drawSelectionInBBox++invalidateAll :: Iteratee MyEvent XournalStateIO ()+invalidateAll = do+  xstate <- getSt+  let cinfoMap  = get canvasInfoMap xstate+      keys = M.keys cinfoMap +  invalidateGen keys Nothing drawPageInBBox++invalidateOther :: Iteratee MyEvent XournalStateIO ()+invalidateOther = do +  xstate <- getSt+  let currCvsId = get currentCanvas xstate+      cinfoMap  = get canvasInfoMap xstate+      keys = M.keys cinfoMap +  invalidateGen (filter (/=currCvsId) keys) Nothing drawPageInBBox++-- invalidate :: CanvasId -> Iteratee MyEvent XournalStateIO () +-- invalidate cid = invalidateGenSingle cid Nothing drawPageInBBox +  +invalidate :: CanvasId -> Iteratee MyEvent XournalStateIO () +invalidate cid = invalidateSelSingle cid Nothing drawPageInBBox drawSelectionInBBox++invalidateInBBox :: CanvasId -> BBox -> Iteratee MyEvent XournalStateIO ()+invalidateInBBox cid bbox = invalidateSelSingle cid (Just bbox) drawPageInBBox drawSelectionInBBox++invalidateDrawBBox :: CanvasId -> BBox -> Iteratee MyEvent XournalStateIO () +invalidateDrawBBox cid bbox = invalidateSelSingle cid (Just bbox) drawBBox drawBBoxSel++invalidateBBoxOnly :: CanvasId -> Iteratee MyEvent XournalStateIO () +invalidateBBoxOnly cid = invalidateSelSingle cid Nothing drawBBoxOnly drawSelectionInBBox+
+ lib/Application/HXournal/Coroutine/Eraser.hs view
@@ -0,0 +1,86 @@+module Application.HXournal.Coroutine.Eraser where++import Graphics.UI.Gtk hiding (get,set,disconnect)+import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Device+import Application.HXournal.Draw+import Application.HXournal.Coroutine.EventConnect+import Application.HXournal.Coroutine.Draw+import Application.HXournal.Accessor+import Application.HXournal.ModelAction.Page+import Application.HXournal.ModelAction.Eraser+import Graphics.Xournal.Type+import Graphics.Xournal.Type.Map+import Graphics.Xournal.HitTest+import Control.Monad.Coroutine.SuspensionFunctors+import Control.Monad.Trans+import qualified Control.Monad.State as St+import Control.Category+import Data.Label+import qualified Data.IntMap as IM+import Prelude hiding ((.), id)++eraserStart :: CanvasId +               -> PointerCoord +               -> Iteratee MyEvent XournalStateIO ()+eraserStart cid pcoord = do +    xstate <- changeCurrentCanvasId cid +    let cvsInfo = getCanvasInfo cid xstate+        zmode = get (zoomMode.viewInfo) cvsInfo+    geometry <- getCanvasGeometry cvsInfo +    let (x,y) = device2pageCoord geometry zmode pcoord +    connidup   <- connectPenUp cvsInfo     +    connidmove <- connectPenMove cvsInfo   +    strs <- getAllStrokeBBoxInCurrentPage+    eraserProcess cid geometry connidup connidmove strs (x,y)+  +eraserProcess :: CanvasId+              -> CanvasPageGeometry+              -> ConnectId DrawingArea -> ConnectId DrawingArea +              -> [StrokeBBox] +              -> (Double,Double)+              -> Iteratee MyEvent XournalStateIO ()+eraserProcess cid cpg connidmove connidup strs (x0,y0) = do +  r <- await +  xstate <- getSt+  let cvsInfo = getCanvasInfo cid xstate +  case r of +    PenMove _cid' pcoord -> do +      let zmode  = get (zoomMode.viewInfo) cvsInfo+          (x,y) = device2pageCoord cpg zmode pcoord +          line = ((x0,y0),(x,y))+          hittestbbox = mkHitTestBBox line strs   +          (hitteststroke,hitState) = +            St.runState (hitTestStrokes line hittestbbox) False+      if hitState +        then do +          let currxoj     = unView . get xournalstate $ xstate +              pgnum       = get currentPageNum cvsInfo+              currpage    = getPage cvsInfo+              currlayer = case IM.lookup 0 (pbm_layers currpage) of+                            Nothing -> error "something wrong in eraserProcess"+                            Just l -> l+              +              (newstrokes,maybebbox) = St.runState (eraseHitted hitteststroke) Nothing+              newlayerbbox = currlayer { layerbbox_strokes = newstrokes }    +              newpagebbox = currpage { pbm_layers = IM.adjust (const newlayerbbox) 0 (pbm_layers currpage) } +              newxojbbox = currxoj { xbm_pages= IM.adjust (const newpagebbox) pgnum (xbm_pages currxoj) }+              newxojstate = ViewAppendState newxojbbox+              xstate' = set xournalstate newxojstate +                        . updatePageAll newxojstate $ xstate +          lift $ St.put xstate' +          case maybebbox of +            Just bbox -> invalidateDrawBBox cid bbox+            Nothing -> return ()+          newstrs <- getAllStrokeBBoxInCurrentPage+          eraserProcess cid cpg connidup connidmove newstrs (x,y)+        else eraserProcess cid cpg connidmove connidup strs (x,y) +    PenUp _cid' _pcoord -> do +      disconnect connidmove +      disconnect connidup +      invalidateAll+    _ -> return ()+
+ lib/Application/HXournal/Coroutine/EventConnect.hs view
@@ -0,0 +1,54 @@+module Application.HXournal.Coroutine.EventConnect where++import Graphics.UI.Gtk hiding (get,set,disconnect)+import Application.HXournal.Type.Event+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Device+import Application.HXournal.Type.Coroutine++import qualified Control.Monad.State as St+import Control.Applicative+import Control.Monad.Trans++import Control.Category+import Data.Label +import Prelude hiding ((.), id)++disconnect :: (WidgetClass w) => ConnectId w +              -> Iteratee MyEvent XournalStateIO ()+disconnect = liftIO . signalDisconnect++connectPenUp :: CanvasInfo -> Iteratee MyEvent XournalStateIO (ConnectId DrawingArea)+connectPenUp cinfo = do +  let cid = get canvasId cinfo+      canvas = get drawArea cinfo +  connPenUp canvas cid ++connectPenMove :: CanvasInfo -> Iteratee MyEvent XournalStateIO (ConnectId DrawingArea)+connectPenMove cinfo = do +  let cid = get canvasId cinfo+      canvas = get drawArea cinfo +  connPenMove canvas cid ++connPenMove :: (WidgetClass w) => +               w +               -> CanvasId +               -> Iteratee MyEvent XournalStateIO (ConnectId w) +connPenMove c cid = do +  callbk <- get callBack <$> lift St.get +  dev <- get deviceList <$> lift St.get +  liftIO (c `on` motionNotifyEvent $ tryEvent $ do +             p <- getPointer dev+             liftIO (callbk (PenMove cid p)))++connPenUp :: (WidgetClass w) => +             w +             -> CanvasId+             -> Iteratee MyEvent XournalStateIO (ConnectId w) +connPenUp c cid = do +  callbk <- get callBack <$> lift St.get +  dev <- get deviceList <$> lift St.get +  liftIO (c `on` buttonReleaseEvent $ tryEvent $ do +             p <- getPointer dev+             liftIO (callbk (PenMove cid p)))
+ lib/Application/HXournal/Coroutine/File.hs view
@@ -0,0 +1,103 @@+module Application.HXournal.Coroutine.File where++import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.XournalState+import Application.HXournal.Accessor+import Application.HXournal.ModelAction.File +import Application.HXournal.Coroutine.Draw+import Application.HXournal.ModelAction.Window+import Application.HXournal.Builder +import Control.Monad.Trans+import Control.Applicative+import Graphics.Xournal.Type.Map+import Graphics.Xournal.Type.Select+import Graphics.UI.Gtk hiding (get,set)+import Control.Category+import Data.Label+import Prelude hiding ((.),id)+import qualified Data.ByteString.Lazy as L++fileNew :: Iteratee MyEvent XournalStateIO ()+fileNew = do +    liftIO $ putStrLn "fileNew called"+    xstate <- getSt +    xstate' <- liftIO $ getFileContent Nothing xstate +    putSt xstate' +    liftIO $ setTitleFromFileName xstate'+    invalidateAll ++fileSave :: Iteratee MyEvent XournalStateIO () +fileSave = do +    xstate <- getSt +    case get currFileName xstate of+      Nothing -> fileSaveAs +      Just filename -> do     +        let xojstate = get xournalstate xstate+        let xoj = case xojstate of +                    ViewAppendState xojmap -> xournalFromXournalBBoxMap xojmap +                    SelectState txoj -> xournalFromXournalBBoxMap +                                        $ XournalBBoxMap <$> tx_pages $ txoj +        liftIO . L.writeFile filename . builder $ xoj++fileOpen :: Iteratee MyEvent XournalStateIO ()+fileOpen = do +    liftIO $ putStrLn "file open clicked"+    dialog <- liftIO $ fileChooserDialogNew Nothing Nothing +                                            FileChooserActionOpen +                                            [ ("OK", ResponseOk) +                                            , ("Cancel", ResponseCancel) ]+    res <- liftIO $ dialogRun dialog+    -- liftIO $ putStrLn $ show res+    case res of +      ResponseDeleteEvent -> liftIO $ widgetDestroy dialog+      ResponseOk ->  do+        mfilename <- liftIO $ fileChooserGetFilename dialog +        case mfilename of +          Nothing -> return () +          Just filename -> do +            liftIO $ putStrLn $ show filename +            xstate <- getSt +            xstateNew <- liftIO $ getFileContent (Just filename) xstate+            putSt xstateNew +            liftIO $ setTitleFromFileName xstateNew             +            invalidateAll +        liftIO $ widgetDestroy dialog+      ResponseCancel -> liftIO $ widgetDestroy dialog+      _ -> error "??? in fileOpen " +    return ()++fileSaveAs :: Iteratee MyEvent XournalStateIO ()+fileSaveAs = do +    liftIO $ putStrLn "file save as clicked"+    dialog <- liftIO $ fileChooserDialogNew Nothing Nothing +                                            FileChooserActionSave +                                            [ ("OK", ResponseOk) +                                            , ("Cancel", ResponseCancel) ]+    res <- liftIO $ dialogRun dialog+    -- liftIO $ putStrLn $ show response+    case res of +      ResponseDeleteEvent -> liftIO $ widgetDestroy dialog+      ResponseOk -> do+        mfilename <- liftIO $ fileChooserGetFilename dialog +        case mfilename of +          Nothing -> return () +          Just filename -> do +            liftIO $ putStrLn $ show filename +            xstate <- getSt +            let xstateNew = set currFileName (Just filename) xstate +            let xojstate = get xournalstate xstateNew+            let xoj = case xojstate of +                        ViewAppendState xojmap -> xournalFromXournalBBoxMap xojmap +                        SelectState txoj -> xournalFromXournalBBoxMap +                                            $ XournalBBoxMap <$> tx_pages $ txoj +            liftIO . L.writeFile filename . builder $ xoj+            putSt xstateNew                                     +            liftIO $ setTitleFromFileName xstateNew +        liftIO $ widgetDestroy dialog+      ResponseCancel -> liftIO $ widgetDestroy dialog+      _ -> error "??? in fileSaveAs"+    return ()+++
+ lib/Application/HXournal/Coroutine/Highlighter.hs view
@@ -0,0 +1,12 @@+module Application.HXournal.Coroutine.Highlighter where++import Application.HXournal.Device +import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.XournalState+import Control.Monad.Trans++highlighterStart :: PointerCoord -> Iteratee MyEvent XournalStateIO ()+highlighterStart _pcoord = do +  liftIO $ putStrLn "highlighter started"+
+ lib/Application/HXournal/Coroutine/Mode.hs view
@@ -0,0 +1,39 @@+module Application.HXournal.Coroutine.Mode where++import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.XournalState+import Application.HXournal.Accessor++import Graphics.Xournal.Type.Map+import Graphics.Xournal.Type.Select++import Control.Monad.Trans++import Control.Applicative+import Control.Category+import Data.Label+import Prelude hiding ((.),id)++modeChange :: MyEvent -> Iteratee MyEvent XournalStateIO ()+modeChange ToViewAppendMode = do +  xstate <- getSt+  let xojstate = get xournalstate xstate+  case xojstate of +    ViewAppendState _ -> return () +    SelectState txoj -> do +      liftIO $ putStrLn "to view append mode"+      putSt +        . set xournalstate (ViewAppendState (XournalBBoxMap <$> tx_pages $ txoj))+        $ xstate  +modeChange ToSelectMode = do +  xstate <- getSt+  let xojstate = get xournalstate xstate+  case xojstate of +    ViewAppendState xoj -> do +      liftIO $ putStrLn "to select mode"+      putSt+        . set xournalstate (SelectState (tempXournalSelectFromXournalBBoxMap xoj))+        $ xstate  +    SelectState _ -> return ()+modeChange _ = return ()
+ lib/Application/HXournal/Coroutine/Page.hs view
@@ -0,0 +1,126 @@+module Application.HXournal.Coroutine.Page where++import Application.HXournal.Type.Event+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Draw+import Application.HXournal.Accessor+import Application.HXournal.Coroutine.Draw+import Application.HXournal.ModelAction.Adjustment+import Graphics.Xournal.Type +import Graphics.Xournal.Type.Map+import Graphics.UI.Gtk hiding (get,set)+import Application.HXournal.ModelAction.Page+import qualified Control.Monad.State as St +import Control.Monad.Trans+import Control.Category+import Data.Label+import Prelude hiding ((.), id)+import Text.Xournal.Type+import Graphics.Xournal.Type.Select+import qualified Data.IntMap as IM++changePage :: (Int -> Int) -> Iteratee MyEvent XournalStateIO () +changePage modifyfn = do +    xstate <- getSt +    let currCvsId = get currentCanvas xstate+        -- cinfoMap = get canvasInfoMap xstate+        currCvsInfo = getCanvasInfo currCvsId xstate   +    let xojst = get xournalstate $ xstate +    case xojst of +      ViewAppendState xoj -> do +        let pgs = xbm_pages xoj +            totalnumofpages = IM.size pgs+            oldpage = get currentPageNum currCvsInfo+            lpage = case IM.lookup (totalnumofpages-1) pgs of+                      Nothing -> error "error in changePage"+                      Just p -> p            +        (xstate',xoj',_pages',_totalnumofpages',newpage) <-+          if (modifyfn oldpage >= totalnumofpages) +          then do +            let npage = mkPageBBoxMapFromPageBBox +                        . mkPageBBoxFromPage+                        . newPageFromOld +                        . pageFromPageBBoxMap $ lpage+                npages = IM.insert totalnumofpages npage pgs +                newxoj = xoj { xbm_pages = npages } +                xstate' = set xournalstate (ViewAppendState newxoj) xstate+            putSt xstate'+            return (xstate',newxoj,npages,totalnumofpages+1,totalnumofpages)+          else if modifyfn oldpage < 0 +                 then return (xstate,xoj,pgs,totalnumofpages,0)+                 else return (xstate,xoj,pgs,totalnumofpages,modifyfn oldpage)+        let Dim w h = pageDim lpage+            (hadj,vadj) = get adjustments currCvsInfo+        liftIO $ do +          adjustmentSetUpper hadj w +          adjustmentSetUpper vadj h +          adjustmentSetValue hadj 0+          adjustmentSetValue vadj 0+        let currCvsInfo' = setPage (ViewAppendState xoj') newpage currCvsInfo +            xstate'' = updatePageAll (ViewAppendState xoj')+                       . updateCanvasInfo currCvsInfo' +                       $ xstate'+        lift . St.put $ xstate'' +        invalidate currCvsId +      SelectState txoj -> do +        let pgs = tx_pages txoj +            totalnumofpages = IM.size pgs+            oldpage = get currentPageNum currCvsInfo+            lpage = case IM.lookup (totalnumofpages-1) pgs of+                      Nothing -> error "error in changePage"+                      Just p -> p            +        (xstate',txoj',_pages',_totalnumofpages',newpage) <-+          if (modifyfn oldpage >= totalnumofpages) +          then do +            let npage = mkPageBBoxMapFromPageBBox +                        . mkPageBBoxFromPage+                        . newPageFromOld +                        . pageFromPageBBoxMap $ lpage+                npages = IM.insert totalnumofpages npage pgs +                newtxoj = txoj { tx_pages = npages } +                xstate' = set xournalstate (SelectState newtxoj) xstate+            putSt xstate'+            return (xstate',newtxoj,npages,totalnumofpages+1,totalnumofpages)+          else if modifyfn oldpage < 0 +                 then return (xstate,txoj,pgs,totalnumofpages,0)+                 else return (xstate,txoj,pgs,totalnumofpages,modifyfn oldpage)+        let Dim w h = pageDim lpage+            (hadj,vadj) = get adjustments currCvsInfo+        liftIO $ do +          adjustmentSetUpper hadj w +          adjustmentSetUpper vadj h +          adjustmentSetValue hadj 0+          adjustmentSetValue vadj 0+        let currCvsInfo' = setPage (SelectState txoj') newpage currCvsInfo +            xstate'' = updatePageAll (SelectState txoj')+                       . updateCanvasInfo currCvsInfo' +                       $ xstate'+        lift . St.put $ xstate'' +        invalidate currCvsId +      ++pageZoomChange :: ZoomMode -> Iteratee MyEvent XournalStateIO () +pageZoomChange zmode = do +    xstate <- getSt +    let currCvsId = get currentCanvas xstate+        cinfoMap = get canvasInfoMap xstate+        currCvsInfo = case IM.lookup currCvsId cinfoMap of +                        Nothing -> error " no such cvsinfo in pageZoomChange"  +                        Just cinfo -> cinfo +    let canvas = get drawArea currCvsInfo+    let page = getPage currCvsInfo +    let Dim w h = pageDim page+    cpg <- liftIO (getCanvasPageGeometry canvas page (0,0))        +    let (w',h') = canvas_size cpg +    let (hadj,vadj) = get adjustments currCvsInfo +        s = 1.0 / getRatioFromPageToCanvas cpg zmode+    liftIO $ setAdjustments (hadj,vadj) (w,h) (0,0) (0,0) (w'*s,h'*s)+    let currCvsInfo' = set (zoomMode.viewInfo) zmode+                       . set (viewPortOrigin.viewInfo) (0,0)+                       $ currCvsInfo +        xstate' = updateCanvasInfo currCvsInfo' xstate+    putSt xstate' +    invalidate currCvsId       +
+ lib/Application/HXournal/Coroutine/Pen.hs view
@@ -0,0 +1,78 @@+module Application.HXournal.Coroutine.Pen where++import Graphics.UI.Gtk hiding (get,set,disconnect)+import Application.HXournal.Device +import Application.HXournal.Type.Event+import Application.HXournal.Type.Enum+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Coroutine.Draw+import Application.HXournal.Coroutine.EventConnect+import Application.HXournal.Accessor+import Application.HXournal.ModelAction.Pen+import Application.HXournal.ModelAction.Page+import Application.HXournal.Draw+import Control.Monad.Trans+import qualified Control.Monad.State as St+import Control.Monad.Coroutine.SuspensionFunctors+import Data.Sequence hiding (filter)+import qualified Data.Map as M+import Data.Maybe +import Control.Category+import Data.Label+import Prelude hiding ((.), id)+import Graphics.Xournal.Render.BBox+++penStart :: CanvasId -> PointerCoord -> Iteratee MyEvent XournalStateIO ()+penStart cid pcoord = do +    xstate <- changeCurrentCanvasId cid +    let cvsInfo = getCanvasInfo cid xstate +    let currxoj = unView . get xournalstate $ xstate        +        -- page = getPage cvsInfo +        pagenum = get currentPageNum cvsInfo+        -- (x0,y0) = get (viewPortOrigin.viewInfo) cvsInfo+        pinfo = get penInfo xstate+        zmode = get (zoomMode.viewInfo) cvsInfo+    geometry <- getCanvasGeometry cvsInfo +    let (x,y) = device2pageCoord geometry zmode pcoord +    connidup   <- connectPenUp   cvsInfo +    connidmove <- connectPenMove cvsInfo +    pdraw <-penProcess cid geometry connidmove connidup (empty |> (x,y)) (x,y) +    let (newxoj,bbox) = addPDraw pinfo currxoj pagenum pdraw+        bbox' = inflate bbox (get (penWidth.penInfo) xstate) +        xstate' = set xournalstate (ViewAppendState newxoj) +                  . updatePageAll (ViewAppendState newxoj)+                  $ xstate+    putSt xstate'+    mapM_ (flip invalidateInBBox bbox') . filter (/=cid) $ otherCanvas xstate' +++penProcess :: CanvasId+           -> CanvasPageGeometry+           -> ConnectId DrawingArea -> ConnectId DrawingArea +           -> Seq (Double,Double) -> (Double,Double) +           -> Iteratee MyEvent XournalStateIO (Seq (Double,Double))+penProcess cid cpg connidmove connidup pdraw (x0,y0) = do +  r <- await +  xstate <- lift St.get+  let cvsInfo = getCanvasInfo cid xstate+  case r of +    PenMove _cid' pcoord -> do +      let canvas = get drawArea cvsInfo+          zmode  = get (zoomMode.viewInfo) cvsInfo+          pcolor = get (penColor.penInfo) xstate +          pwidth = get (penWidth.penInfo) xstate +          (x,y) = device2pageCoord cpg zmode pcoord +          pcolRGBA = fromJust (M.lookup pcolor penColorRGBAmap) +      liftIO $ drawSegment canvas cpg zmode pwidth pcolRGBA (x0,y0) (x,y)+      penProcess cid cpg connidmove connidup (pdraw |> (x,y)) (x,y) +    PenUp _cid' pcoord -> do +      let zmode = get (zoomMode.viewInfo) cvsInfo+          (x,y) = device2pageCoord cpg zmode pcoord +      disconnect connidmove+      disconnect connidup+      return (pdraw |> (x,y)) +    _ -> do+      penProcess cid cpg connidmove connidup pdraw (x0,y0)
+ lib/Application/HXournal/Coroutine/Scroll.hs view
@@ -0,0 +1,45 @@+module Application.HXournal.Coroutine.Scroll where++import Application.HXournal.Type.Event +import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Coroutine.Draw+import qualified Data.IntMap as IM+import Control.Monad.Trans+import qualified Control.Monad.State as St+import Control.Monad.Coroutine.SuspensionFunctors+import Control.Category+import Data.Label+import Prelude hiding ((.), id)++vscrollStart :: CanvasId -> Iteratee MyEvent XournalStateIO () +vscrollStart cid = vscrollMove cid +        +vscrollMove :: CanvasId -> Iteratee MyEvent XournalStateIO () +vscrollMove cid = do    +  ev <- await +  case ev of+    VScrollBarMoved _cid' v -> do +      xstate <- lift St.get +      let cinfoMap = get canvasInfoMap xstate+          maybeCvs = IM.lookup cid cinfoMap +      case maybeCvs of +        Nothing -> return ()+        Just cvsInfo -> do +          let vm_orig = get (viewPortOrigin.viewInfo) cvsInfo+          let cvsInfo' = set (viewPortOrigin.viewInfo) (fst vm_orig,v)+                         $ cvsInfo +              cinfoMap' = IM.adjust (const cvsInfo') cid cinfoMap  +              xstate' = set canvasInfoMap cinfoMap' +                        . set currentCanvas cid+                        $ xstate+          lift . St.put $ xstate'+          invalidateBBoxOnly cid+          vscrollMove cid +    VScrollBarEnd cid' _v -> do +      invalidate cid' +      return ()+    _ -> return ()       +    +
+ lib/Application/HXournal/Coroutine/Select.hs view
@@ -0,0 +1,278 @@+module Application.HXournal.Coroutine.Select where++import Graphics.UI.Gtk hiding (get,set,disconnect)+import Application.HXournal.Type.Event +import Application.HXournal.Type.Enum+import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.Clipboard+import Application.HXournal.Type.XournalState+import Application.HXournal.Accessor+import Application.HXournal.Device+import Application.HXournal.Draw+import Application.HXournal.Coroutine.EventConnect+import Application.HXournal.Coroutine.Draw+import Application.HXournal.Coroutine.Mode+import Application.HXournal.ModelAction.Page+import Application.HXournal.ModelAction.Select+import Control.Monad.Trans+import Control.Monad.Coroutine.SuspensionFunctors+import Control.Category+import Data.Label+import Prelude hiding ((.), id)+import Graphics.Xournal.Type+import Graphics.Xournal.Type.Select+import Graphics.Xournal.HitTest+import Graphics.Xournal.Render.BBox++import Data.Maybe++-- | main mouse pointer click entrance in rectangular selection mode. +--   choose either starting new rectangular selection or move previously +--   selected selection. ++selectRectStart :: CanvasId -> PointerCoord -> Iteratee MyEvent XournalStateIO () +selectRectStart cid pcoord = do    +    xstate <- changeCurrentCanvasId cid +    let cvsInfo = getCanvasInfo cid xstate+        zmode = get (zoomMode.viewInfo) cvsInfo     +    geometry <- getCanvasGeometry cvsInfo+    let (x,y) = device2pageCoord geometry zmode pcoord +    connidup   <- connectPenUp cvsInfo +    connidmove <- connectPenMove cvsInfo+    strs <- getAllStrokeBBoxInCurrentPage+    case get currentPage cvsInfo of +      Right tpage -> if hitInSelection tpage (x,y)+                       then do +                         moveSelectRectangle cvsInfo +                                             geometry +                                             zmode +                                             connidup +                                             connidmove +                                             (x,y) +                                             (x,y)+                       else +                         newSelectRectangle cvsInfo +                                            geometry +                                            zmode +                                            connidup +                                            connidmove +                                            strs +                                            (x,y) +                                            (x,y)+      Left _ -> newSelectRectangle cvsInfo +                                   geometry +                                   zmode +                                   connidup +                                   connidmove +                                   strs +                                   (x,y) +                                   (x,y)++      +newSelectRectangle :: CanvasInfo+                   -> CanvasPageGeometry+                   -> ZoomMode+                   -> ConnectId DrawingArea -> ConnectId DrawingArea+                   -> [StrokeBBox] +                   -> (Double,Double)+                   -> (Double,Double)+                   -> Iteratee MyEvent XournalStateIO ()+newSelectRectangle cinfo geometry zmode connidmove connidup strs orig prev = do  +  let cid = get canvasId cinfo  +  r <- await +  case r of +    PenMove _cid' pcoord -> do +      let (x,y) = device2pageCoord geometry zmode pcoord +      let bbox = BBox orig (x,y)+          prevbbox = BBox orig prev+          hittestbbox = mkHitTestInsideBBox bbox strs+          hittedstrs = concat . map unHitted . getB $ hittestbbox+      invalidateInBBox cid (inflate (fromJust (Just bbox `merge` Just prevbbox)) 2)+      invalidateDrawBBox cid bbox+      mapM_ (invalidateDrawBBox cid . strokebbox_bbox) hittedstrs+      newSelectRectangle cinfo geometry zmode connidmove connidup strs orig (x,y) +    PenUp _cid' pcoord -> do +      let (x,y) = device2pageCoord geometry zmode pcoord +      let epage = get currentPage cinfo +          cpn = get currentPageNum cinfo +          +      let bbox = BBox orig (x,y)+          -- prevbbox = BBox orig prev+          hittestbbox = mkHitTestInsideBBox bbox strs+          selectstrs = fmapAL unNotHitted id hittestbbox+          +      xstate <- getSt    +      let SelectState txoj = get xournalstate xstate+          newlayer = LayerSelect (Right selectstrs)+          newpage = case epage of +                      Left pagebbox -> +                        let tpg = tempPageSelectFromPageBBoxMap pagebbox+                        in  tpg { tp_firstlayer = newlayer }+                      Right tpage -> tpage { tp_firstlayer = newlayer } +          newtxoj = txoj { tx_selectpage = Just (cpn,newpage) } +      let ui = get gtkUIManager xstate+      liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectstrs)+      putSt (set xournalstate (SelectState newtxoj) +             . updatePageAll (SelectState newtxoj)+             $ xstate) +      disconnect connidmove+      disconnect connidup +      invalidateAll +    _ -> return ()+         +moveSelectRectangle :: CanvasInfo+                    -> CanvasPageGeometry+                    -> ZoomMode+                    -> ConnectId DrawingArea +                    -> ConnectId DrawingArea+                    -> (Double,Double)+                    -> (Double,Double)+                    -> Iteratee MyEvent XournalStateIO ()+moveSelectRectangle cinfo geometry zmode connidmove connidup orig@(x0,y0) _prev = do+  xstate <- getSt+  -- let cid = get canvasId cinfo +  r <- await +  case r of +    PenMove _cid' pcoord -> do +      let (x,y) = device2pageCoord geometry zmode pcoord +      moveSelectRectangle cinfo geometry zmode connidmove connidup orig (x,y) +    PenUp _cid' pcoord -> do +      let (x,y) = device2pageCoord geometry zmode pcoord +      let offset = (x-x0,y-y0)+          SelectState txoj = get xournalstate xstate+          epage = get currentPage cinfo +          pagenum = get currentPageNum cinfo+      case epage of +        Right tpage -> do +          let newtpage = changeSelectionByOffset tpage offset+              newtxoj = updateTempXournalSelect txoj newtpage pagenum +          putSt (set xournalstate (SelectState newtxoj)+                 . updatePageAll (SelectState newtxoj) +                 $ xstate )+        Left _ -> error "this is impossible, in moveSelectRectangle" +      disconnect connidmove+      disconnect connidup +      invalidateAll +    _ -> return ()+ +deleteSelection :: Iteratee MyEvent XournalStateIO () +deleteSelection = do +  liftIO $ putStrLn "delete selection is called"+  xstate <- getSt+  let -- cinfo = getCurrentCanvasInfo xstate +      SelectState txoj = get xournalstate xstate +      Just (n,tpage) = tx_selectpage txoj+  case strokes (tp_firstlayer tpage) of +    Left _ -> liftIO $ putStrLn "no stroke selection 2 "+    Right alist -> do +      let newlayer = Left . concat . getA $ alist+          newpage = tpage {tp_firstlayer = LayerSelect newlayer} +          newtxoj = updateTempXournalSelect txoj newpage n          +          newxstate = set xournalstate (SelectState newtxoj) xstate+          newxstate' = updatePageAll (SelectState newtxoj) newxstate +      putSt newxstate' +      let ui = get gtkUIManager newxstate'+      liftIO $ toggleCutCopyDelete ui False +      invalidateAll +          +cutSelection :: Iteratee MyEvent XournalStateIO ()  +cutSelection = do+  liftIO $ putStrLn "cutSelection called"+  copySelection +  deleteSelection++copySelection :: Iteratee MyEvent XournalStateIO ()+copySelection = do +  liftIO $ putStrLn "copySelection called"+  xstate <- getSt+  let cinfo = getCurrentCanvasInfo xstate +      etpage = get currentPage cinfo +  case etpage of+    Left _ -> return ()+    Right tpage -> do +      case (strokes . tp_firstlayer) tpage of +        Left _ -> return ()+        Right alist -> do +          let strs = takeHittedStrokes alist +          if null strs +            then return () +            else do +              let newclip = Clipboard strs+                  xstate' = set clipboard newclip xstate +              liftIO $ putStrLn $ "newclipboard with " ++ show strs +              let ui = get gtkUIManager xstate'+              liftIO $ togglePaste ui True +              putSt xstate'+              invalidateAll ++pasteToSelection :: Iteratee MyEvent XournalStateIO () +pasteToSelection = do +  liftIO $ putStrLn "pasteToSelection called" +  modeChange ToSelectMode    +  xstate <- getSt+  let SelectState txoj = get xournalstate xstate+      clipstrs = getClipContents . get clipboard $ xstate+      cinfo = getCurrentCanvasInfo xstate +      pagenum = get currentPageNum cinfo +      tpage = case get currentPage cinfo of +                Left pbbox -> tempPageSelectFromPageBBoxMap pbbox+                Right tp -> tp +      layerselect = tp_firstlayer tpage +      newlayerselect = +        case strokes layerselect of +          Left strs -> (LayerSelect . Right) (strs :- Hitted clipstrs :- Empty)+          Right alist -> (LayerSelect . Right) +                           (concat (interleave id unHitted alist) +                            :- Hitted clipstrs +                            :- Empty )+      tpage' = tpage { tp_firstlayer = newlayerselect }+      txoj' = updateTempXournalSelect txoj tpage' pagenum +      xstate' = updatePageAll (SelectState txoj') +                . set xournalstate (SelectState txoj') +                $ xstate +  putSt xstate' +  let ui = get gtkUIManager xstate' +  liftIO $ toggleCutCopyDelete ui True+  invalidateAll +  +selectPenColorChanged :: PenColor ->  Iteratee MyEvent XournalStateIO () +selectPenColorChanged pcolor = do +  liftIO $ putStrLn "selectPenColorChanged called"+  xstate <- getSt+  let -- cinfo = getCurrentCanvasInfo xstate +      SelectState txoj = get xournalstate xstate +      Just (n,tpage) = tx_selectpage txoj+  case strokes (tp_firstlayer tpage) of +    Left _ -> liftIO $ putStrLn "no stroke selection 2 "+    Right alist -> do +      let alist' = fmapAL id +                     (Hitted . map (changeStrokeColor pcolor) . unHitted) alist+          newlayer = Right alist'+          newpage = tpage {tp_firstlayer = LayerSelect newlayer} +          newtxoj = updateTempXournalSelect txoj newpage n+          newxstate = set xournalstate (SelectState newtxoj) xstate+          newxstate' = updatePageAll (SelectState newtxoj) newxstate +      putSt newxstate' +      invalidateAll +          +selectPenWidthChanged :: Double ->  Iteratee MyEvent XournalStateIO () +selectPenWidthChanged pwidth = do +  liftIO $ putStrLn "selectPenWidthChanged called"+  xstate <- getSt+  let -- cinfo = getCurrentCanvasInfo xstate +      SelectState txoj = get xournalstate xstate +      Just (n,tpage) = tx_selectpage txoj+  case strokes (tp_firstlayer tpage) of +    Left _ -> liftIO $ putStrLn "no stroke selection 2 "+    Right alist -> do +      let alist' = fmapAL id +                     (Hitted . map (changeStrokeWidth pwidth) . unHitted) alist+          newlayer = Right alist'+          newpage = tpage {tp_firstlayer = LayerSelect newlayer} +          newtxoj = updateTempXournalSelect txoj newpage n          +          newxstate = set xournalstate (SelectState newtxoj) xstate+          newxstate' = updatePageAll (SelectState newtxoj) newxstate +      putSt newxstate' +      invalidateAll +
+ lib/Application/HXournal/Coroutine/Window.hs view
@@ -0,0 +1,95 @@+module Application.HXournal.Coroutine.Window where++import Application.HXournal.Type.Event+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.Window+import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Coroutine+import Control.Monad.Trans+import Application.HXournal.ModelAction.Window+import Application.HXournal.Accessor+import Control.Category+import Data.Label+import Prelude hiding ((.),id)+import Graphics.UI.Gtk hiding (get,set)+import qualified Data.IntMap as M++eitherSplit :: SplitType -> Iteratee MyEvent XournalStateIO ()+eitherSplit stype = do+    xstate <- getSt+    let cmap = get canvasInfoMap xstate+        currcid = get currentCanvas xstate+        newcid = newCanvasId cmap +        fstate = get frameState xstate+        -- xojstate = get xournalstate xstate+        enewfstate = splitWindow currcid (newcid,stype) fstate +    case enewfstate of +      Left _ -> return ()+      Right fstate' -> do +        let oldcinfo = case M.lookup currcid cmap of+                         Nothing -> error "noway! in eitherSplit " +                         Just c -> c +        liftIO $ removePanes fstate +        cinfo <- liftIO $ initCanvasInfo xstate newcid +        let cinfo' = set viewInfo (get viewInfo oldcinfo)+                     . set currentPageNum (get currentPageNum oldcinfo)+                     . set currentPage (get currentPage oldcinfo)+                     $ cinfo+        let cmap' = M.insert newcid cinfo' cmap+        liftIO $ putStrLn $ "in window " ++ show (M.keys cmap')+        let rtwin = get rootWindow xstate+            rtcntr = get rootContainer xstate +            xstate' = set canvasInfoMap cmap'+                      . set frameState fstate'+                      $ xstate+        putSt xstate'+        liftIO $ containerRemove rtcntr rtwin++        (win,fstate'') <- liftIO $ constructFrame fstate' cmap'         +        let xstate'' = set frameState fstate'' +                       . set rootWindow win $ xstate'+        putSt xstate''+        liftIO $ boxPackEnd rtcntr win PackGrow 0 +        liftIO $ widgetShowAll rtcntr +++deleteCanvas :: Iteratee MyEvent XournalStateIO ()+deleteCanvas = do +    liftIO $ putStrLn "deleteCanvas"  +    xstate <- getSt+    let cmap = get canvasInfoMap xstate+        currcid = get currentCanvas xstate+        fstate = get frameState xstate+        -- xojstate = get xournalstate xstate+        enewfstate = removeWindow currcid fstate +    case enewfstate of +      Left _ -> return ()+      Right Nothing -> return ()+      Right (Just fstate') -> do +        let oldcinfo = case M.lookup currcid cmap of+                         Nothing -> error "noway! in deleteCanvas " +                         Just c -> c +        liftIO $ removePanes fstate ++        let cmap' = M.delete currcid cmap+            newcurrcid = maximum (M.keys cmap')+        xstate' <- changeCurrentCanvasId newcurrcid +        liftIO $ putStrLn $ "in window " ++ show (M.keys cmap')+        let rtwin = get rootWindow xstate'+            rtcntr = get rootContainer xstate' +            xstate'' = set canvasInfoMap cmap'+                       . set frameState fstate'+                       $ xstate'+        putSt xstate''+        liftIO $ containerRemove rtcntr rtwin++        (win,fstate'') <- liftIO $ constructFrame fstate' cmap'         +        let xstate''' = set frameState fstate'' +                        . set rootWindow win $ xstate''+        putSt xstate'''+        liftIO $ boxPackEnd rtcntr win PackGrow 0 +        liftIO $ widgetShowAll rtcntr ++        liftIO $ widgetDestroy (get scrolledWindow oldcinfo)+        liftIO $ widgetDestroy (get drawArea oldcinfo)+
+ lib/Application/HXournal/Device.hsc view
@@ -0,0 +1,127 @@+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}++#include <gtk/gtk.h>+#include "template-hsc-gtk2hs.h"++module Application.HXournal.Device where++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 DeviceList = DeviceList { dev_core :: CInt+                             , dev_stylus :: CInt+                             , dev_eraser :: CInt } +                deriving Show +                  +data PointerCoord = PointerCoord { pointerType :: PointerType +                                 , pointerX :: Double +                                 , pointerY :: Double } +                  | NoPointerCoord+                  deriving (Show,Eq,Ord)+++foreign import ccall "c_initdevice.h initdevice" c_initdevice+  :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()++initDevice :: IO DeviceList  +initDevice = +  with 0 $ \pcore -> +  with 0 $ \pstylus -> +  with 0 $ \peraser -> do +        c_initdevice pcore pstylus peraser+        core_val <- peek pcore+        stylus_val <- peek pstylus+        eraser_val <- peek peraser+        return $ DeviceList core_val stylus_val eraser_val+                 ++getPointer :: DeviceList -> EventM t PointerCoord+getPointer devlst = do +    ptr <- ask +    (_ty,x,y,mdev,maxf) <- liftIO (getInfo ptr)+    case mdev of +      Nothing -> return (PointerCoord Core x y)+      Just dev -> case maxf of +                    Nothing -> return (PointerCoord Core x y)+                    Just axf -> liftIO $ coord ptr x y dev axf     +  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+          (dev :: CInt) <- #{peek GdkEventButton, device} ptr+          let axisfunc = #{peek GdkEventButton, axes}+          return (ty,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,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,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, 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 +          | device == dev_stylus devlst = do +            (ptrax :: Ptr CDouble ) <- axf ptr +            (wacomx :: Double) <- peekByteOff ptrax 0+            (wacomy :: Double) <- peekByteOff ptrax 8+            return $ PointerCoord Stylus wacomx wacomy +          | device == dev_eraser devlst = do +            (ptrax :: Ptr CDouble ) <- axf ptr +            (wacomx :: Double) <- peekByteOff ptrax 0+            (wacomy :: Double) <- peekByteOff ptrax 8+            return $ PointerCoord Eraser wacomx wacomy +          | otherwise = return $ PointerCoord Core x y++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)+
+ lib/Application/HXournal/Draw.hs view
@@ -0,0 +1,281 @@+module Application.HXournal.Draw where++import Graphics.UI.Gtk hiding (get)+import Graphics.Rendering.Cairo++import Control.Applicative +import Control.Category+import Data.Label+import Prelude hiding ((.),id)++import Text.Xournal.Type++import Graphics.Xournal.Type +import Graphics.Xournal.Type.Select+import Graphics.Xournal.Type.Map+import Graphics.Xournal.Render +import Graphics.Xournal.Render.BBox +import Graphics.Xournal.HitTest+import Application.HXournal.Type +import Application.HXournal.Device++data CanvasPageGeometry = +  CanvasPageGeometry { screen_size :: (Double,Double) +                     , canvas_size :: (Double,Double)+                     , page_size :: (Double,Double)+                     , canvas_origin :: (Double,Double) +                     , page_origin :: (Double,Double)+                     }+  deriving (Show)  ++type PageDrawF = DrawingArea -> PageBBoxMap -> ViewInfo -> Maybe BBox +                 -> IO ()++type PageDrawFSel = DrawingArea -> TempPageSelect -> ViewInfo -> Maybe BBox +                    -> IO ()+++getCanvasPageGeometry :: IPage a => +                         DrawingArea +                         -> a +                         -> (Double,Double) +                         -> IO CanvasPageGeometry+getCanvasPageGeometry canvas page (xorig,yorig) = do +  win <- widgetGetDrawWindow canvas+  (w',h') <- widgetGetSize canvas+  screen <- widgetGetScreen canvas+  (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen+  let (Dim w h) = pageDim page+  (x0,y0) <- drawWindowGetOrigin win+  return $ CanvasPageGeometry (fromIntegral ws, fromIntegral hs) +                              (fromIntegral w', fromIntegral h') +                              (w,h) +                              (fromIntegral x0,fromIntegral y0)+                              (xorig, yorig)++core2pageCoord :: CanvasPageGeometry -> ZoomMode +                  -> (Double,Double) -> (Double,Double)+core2pageCoord cpg@(CanvasPageGeometry (_ws,_hs) (_w',_h') (_w,_h) (_x0,_y0) (xorig,yorig))+               zmode (px,py) = +  let s =  1.0 / getRatioFromPageToCanvas cpg zmode +      (xo,yo) = case zmode of+                  Original -> (xorig,yorig)+                  FitWidth -> (0,yorig)+                  FitHeight -> (xorig,0)+                  _ -> error "not implemented yet in core2pageCoord"+  in (px*s+xo, py*s+yo)+  +wacom2pageCoord :: CanvasPageGeometry +                   -> ZoomMode +                   -> (Double,Double) +                   -> (Double,Double)+wacom2pageCoord cpg@(CanvasPageGeometry (ws,hs) (_w',_h') (_w,_h) (x0,y0) (xorig,yorig)) +                zmode +                (px,py) +  = let (x1,y1) = (ws*px-x0,hs*py-y0)+        s = 1.0 / getRatioFromPageToCanvas cpg zmode+        (xo,yo) = case zmode of+                    Original -> (xorig,yorig)+                    FitWidth -> (0,yorig)+                    FitHeight -> (xorig,0)+                    _ -> error "not implemented wacom2pageCoord"+    in  (x1*s+xo,y1*s+yo)++device2pageCoord :: CanvasPageGeometry +                 -> ZoomMode +                 -> PointerCoord  +                 -> (Double,Double)+device2pageCoord cpg zmode pcoord@(PointerCoord _ _ _)  = + let (px,py) = (,) <$> pointerX <*> pointerY $ pcoord  + in case pointerType pcoord of +      Core -> core2pageCoord  cpg zmode (px,py)+      _    -> wacom2pageCoord cpg zmode (px,py)+device2pageCoord _ _ NoPointerCoord = (-100,-100)+++transformForPageCoord :: CanvasPageGeometry -> ZoomMode -> Render ()+transformForPageCoord cpg zmode = do +  let (xo,yo) = page_origin cpg+  let s = getRatioFromPageToCanvas cpg zmode  +  scale s s+  translate (-xo) (-yo)      +  +updateCanvas :: DrawingArea -> XournalBBox -> Int -> ViewInfo -> IO ()+updateCanvas canvas xoj pagenum vinfo = do +  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+  let currpage = ((!!pagenum).xournalPages) xoj+  geometry <- getCanvasPageGeometry canvas currpage origin+  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord geometry zmode+    cairoDrawPage currpage+  return ()++drawBBoxOnly :: PageDrawF+drawBBoxOnly canvas page vinfo _mbbox = do +  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord geometry zmode+    cairoDrawPageBBoxOnly page+  return ()++++drawPageInBBox :: PageDrawF +drawPageInBBox canvas page vinfo mbbox = do +  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord geometry zmode+    cairoDrawPageBBox mbbox page+    return ()+  return ()++drawBBox :: PageDrawF +drawBBox _ _ _ Nothing = return ()+drawBBox canvas page vinfo (Just bbox) = do +  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    setLineWidth 0.5 +    setSourceRGBA 1.0 0.0 0.0 1.0+    transformForPageCoord geometry zmode+    let (x1,y1) = bbox_upperleft bbox+        (x2,y2) = bbox_lowerright bbox+    rectangle x1 y1 (x2-x1) (y2-y1)+    stroke+  return ()++drawBBoxSel :: PageDrawFSel +drawBBoxSel _ _ _ Nothing = return ()+drawBBoxSel canvas tpg vinfo (Just bbox) = do +  let page = pageBBoxMapFromTempPageSelect tpg+  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    setLineWidth 0.5 +    setSourceRGBA 1.0 0.0 0.0 1.0+    transformForPageCoord geometry zmode+    let (x1,y1) = bbox_upperleft bbox+        (x2,y2) = bbox_lowerright bbox+    rectangle x1 y1 (x2-x1) (y2-y1)+    stroke+  return ()+++getRatioFromPageToCanvas :: CanvasPageGeometry -> ZoomMode -> Double +getRatioFromPageToCanvas _cpg Original = 1.0 +getRatioFromPageToCanvas cpg FitWidth = +  let (w,_)  = page_size cpg +      (w',_) = canvas_size cpg +  in  w'/w+getRatioFromPageToCanvas cpg FitHeight = +  let (_,h)  = page_size cpg +      (_,h') = canvas_size cpg +  in  h'/h+getRatioFromPageToCanvas _cpg (Zoom s) = s ++drawSegment :: DrawingArea+               -> CanvasPageGeometry +               -> ZoomMode +               -> Double +               -> (Double,Double,Double,Double) +               -> (Double,Double) +               -> (Double,Double) +               -> IO () +drawSegment canvas cpg zmode wdth (r,g,b,a) (x0,y0) (x,y) = do +  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord cpg zmode+    setSourceRGBA r g b a+    setLineWidth wdth+    moveTo x0 y0+    lineTo x y+    stroke+  +showXournalBBox :: DrawingArea -> XournalBBox -> Int -> ViewInfo -> IO ()+showXournalBBox canvas xojbbox pagenum vinfo = do +  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+  let currpagebbox = ((!!pagenum).xojbbox_pages) xojbbox+      currpage = pageFromPageBBox currpagebbox+      strs = do +        l <- pagebbox_layers currpagebbox +        s <- layerbbox_strokes l+        return s +  geometry <- getCanvasPageGeometry canvas currpage origin+  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord geometry zmode+    setSourceRGBA 1.0 0 0 1.0 +    setLineWidth  0.5 +    let f str = do +          let BBox (ulx,uly) (lrx,lry) = strokebbox_bbox str +          rectangle ulx uly (lrx-ulx) (lry-uly)+          stroke +    mapM_ f strs +  return ()++showBBox :: DrawingArea -> CanvasPageGeometry -> ZoomMode -> BBox -> IO ()+showBBox canvas cpg zmode (BBox (ulx,uly) (lrx,lry)) = do +  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord cpg zmode+    setSourceRGBA 0.0 1.0 0.0 1.0 +    setLineWidth  1.0 +    rectangle ulx uly (lrx-ulx) (lry-uly)    +    stroke+  return ()++dummyDraw :: PageDrawFSel +dummyDraw _canvas _pgslct _vinfo _mbbox = do +  putStrLn "dummy draw"+  return ()+  +  +drawSelectionInBBox :: PageDrawFSel +drawSelectionInBBox canvas tpg vinfo mbbox = do +  let zmode  = get zoomMode vinfo+      origin = get viewPortOrigin vinfo+      page = pageBBoxMapFromTempPageSelect tpg+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  +  boxdrawaction <-  +    case strokes (tp_firstlayer tpg) of+      Right alist -> do +        return $ do +          setSourceRGBA 0.0 0.0 1.0 1.0+          let hitstrs = concatMap unHitted (getB alist)+              oneboxdraw str = do +                let bbox@(BBox (x1,y1) (x2,y2)) = strokebbox_bbox str+                    drawbox = do { rectangle x1 y1 (x2-x1) (y2-y1); stroke }+                case mbbox of +                  Just bboxarg -> if hitTestBBoxBBox bbox bboxarg +                                    then drawbox+                                    else return () +                  Nothing -> drawbox +          mapM_ oneboxdraw hitstrs                       +      Left _ -> return $ return ()  +  +  renderWithDrawable win $ do+    transformForPageCoord geometry zmode+    cairoDrawPageBBox mbbox page+    boxdrawaction +      +++  ++  +
+ lib/Application/HXournal/GUI.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Application.HXournal.GUI where++import Application.HXournal.Type.XournalState +import Application.HXournal.Type.Event++import Application.HXournal.Coroutine.Callback+import Application.HXournal.Device+import Application.HXournal.Coroutine+import Application.HXournal.GUI.Menu+import Application.HXournal.ModelAction.File +import Application.HXournal.ModelAction.Window++import Graphics.UI.Gtk hiding (get,set)++import Control.Applicative ++import Data.IORef++import Control.Category+import Data.Label+import Prelude hiding ((.),id)+++startGUI :: Maybe FilePath -> IO () +startGUI mfname = do +  initGUI+  window <- windowNew   +  +  devlst <- initDevice +  (tref,sref) <- initCoroutine devlst window+  st0 <- readIORef sref +  st1 <- getFileContent mfname st0+  writeIORef sref st1+  (winCvsArea, wconf) <- constructFrame +                         <$> get frameState +                         <*> get canvasInfoMap $ st1+  +  setTitleFromFileName st1+  vbox <- vBoxNew False 0 +  +  let st2 = set frameState wconf +            . set rootWindow winCvsArea +            . set rootContainer (castToBox vbox) $ st1 +  writeIORef sref st2+  ui <- getMenuUI tref sref  +  +  let st3 = set gtkUIManager ui st2 +  writeIORef sref st3 +  +  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 winCvsArea PackGrow 0 +  -- cursorDot <- cursorNew BlankCursor  +  onDestroy window mainQuit+  widgetShowAll window+  +  -- initialized+  bouncecallback tref sref Initialized     +  mainGUI +  return ()+
+ lib/Application/HXournal/GUI/Menu.hs view
@@ -0,0 +1,600 @@+{-# LANGUAGE QuasiQuotes #-}++module Application.HXournal.GUI.Menu where++import Application.HXournal.Util.Verbatim+import Application.HXournal.Coroutine.Callback+import Application.HXournal.Type+import Application.HXournal.Type.Clipboard+import Control.Monad.Coroutine.SuspensionFunctors+import Data.IORef+import Data.Maybe+import Control.Category+import Data.Label+import Prelude hiding ((.),id)+import Graphics.UI.Gtk hiding (set,get)+import qualified Graphics.UI.Gtk as Gtk (set)+import System.FilePath+import Text.Xournal.Predefined +import Paths_hxournal++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="OPENA" />                        +       <menuitem action="SAVEA" />                        +       <menuitem action="SAVEASA" />                        +       <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" />                        +    </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="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" />                          +       </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" />+    </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 "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++getMenuUI :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))+             -> IORef HXournalState +             -> IO UIManager+getMenuUI tref sref = do ++  let actionNewAndRegister :: String -> String +                           -> Maybe String -> Maybe StockId+                           -> Maybe MyEvent +                           -> IO Action+      actionNewAndRegister 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 +              bouncecallback tref sref ev+            return a+  +  -- 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)+  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)+  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)+  +  -- view menu+++  fscra     <- actionNewAndRegister "FSCRA"     "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen)+  zooma     <- actionNewAndRegister "ZOOMA"     "Zoom" (Just "Just a Stub") 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)+  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)+  +  -- options menu +  uxinputa <- actionNewAndRegister "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 <- actionNewAndRegister "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing (justMenu MenuPressureSensitivity)+  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_ (\act -> actionGroupAddActionWithAccel agr act Nothing)   +        [ newa, annpdfa, opena, savea, saveasa, recenta, printa, exporta, quita+        , undoa, redoa, cuta, copya, pastea, deletea+        , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma+        , fstpagea, prvpagea, nxtpagea, lstpagea, shwlayera, hidlayera+        , hsplita, vsplita, delcvsa+        , newpgba, newpgaa, newpgea, delpga, newlyra, dellyra, ppsizea, ppclra+        , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa+        , shpreca, rulera, clra, penopta  {- selregna, selrecta, vertspa, handa, -}+        , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta+        , setdefopta+        , uxinputa, dcrdcorea, ersrtipa, pressrsensa, pghilta, mltpgvwa+        , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea +        , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa +        , abouta +        , defaulta         +        ] +  actionGroupAddRadioActions agr viewmods 0 (\_ -> return ())+  actionGroupAddRadioActions agr pointmods 0 (assignPoint sref)+  actionGroupAddRadioActions agr penmods   0 (assignPenMode tref sref)+  actionGroupAddRadioActions agr colormods 0 (assignColor sref) +++ +  let disabledActions = +        [ annpdfa, recenta, printa, exporta+        , undoa, redoa, cuta, copya, pastea, deletea+        , fscra,  zmina, zmouta, setzma+        , shwlayera, hidlayera+        , newpgba, newpgaa, newpgea, delpga, newlyra, dellyra, ppsizea, ppclra+        , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa+        , shpreca, rulera +        , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta+        , setdefopta+        , uxinputa, dcrdcorea, ersrtipa, pressrsensa, pghilta, mltpgvwa+        , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea +        , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa +        , abouta +        , defaulta         +        ] +      enabledActions = +        [ opena, savea, saveasa, quita, fstpagea, prvpagea, nxtpagea, lstpagea+        , clra, penopta, zooma, nrmsizea, pgwdtha  -- , selrecta+        ]+  +  mapM_ (\x->actionSetSensitive x True) enabledActions  +  mapM_ (\x->actionSetSensitive x False) disabledActions+  +  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 False++  Just ra4 <- actionGroupGetAction agr "VERTSPA"+  actionSetSensitive ra4 False++  Just ra5 <- actionGroupGetAction agr "HANDA"+  actionSetSensitive ra5 False++  Just ra6 <- actionGroupGetAction agr "CONTA"+  actionSetSensitive ra6 False ++  Just toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1"+  toolbarSetStyle (castToToolbar toolbar1) ToolbarIcons ++  Just toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2"+  toolbarSetStyle (castToToolbar toolbar2) ToolbarIcons +  +  return ui   ++assignPenMode :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))+                 -> IORef HXournalState -> RadioAction -> IO ()+assignPenMode tref sref a = do +    v <- radioActionGetCurrentValue a+    let t = int2PenType v+    st <- readIORef sref +    case t of +      Left pm -> do +        let stNew = set (penType.penInfo) pm st +        writeIORef sref stNew +        bouncecallback tref sref ToViewAppendMode+      Right sm -> do +        let stNew = set (selectType.selectInfo) sm st +        writeIORef sref stNew +        bouncecallback tref sref ToSelectMode+        ++assignColor :: IORef HXournalState -> RadioAction -> IO () +assignColor sref a = do +    v <- radioActionGetCurrentValue a+    let c = int2Color v+    st <- readIORef sref +    let callback = get callBack st+    let stNew = set (penColor.penInfo) c st +    writeIORef sref stNew +    callback (PenColorChanged c)++assignPoint :: IORef HXournalState -> RadioAction -> IO () +assignPoint sref a = do +    v <- radioActionGetCurrentValue a+    let w = int2Point v+    st <- readIORef sref +    let stNew = set (penWidth.penInfo) w st +    let callback = get callBack st        +    writeIORef sref stNew +    callback (PenWidthChanged w)++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 :: Int -> Double +int2Point 0 = predefined_veryfine +int2Point 1 = predefined_fine+int2Point 2 = predefined_medium+int2Point 3 = predefined_thick+int2Point 4 = predefined_verythick+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"
+ lib/Application/HXournal/Job.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Application.HXournal.Job where++import Application.HXournal.GUI+import Application.HXournal.Builder+import qualified Data.ByteString.Lazy as L+import Text.Xournal.Parse++startJob :: Maybe FilePath -> IO () +startJob mfname = do +  putStrLn "job started"+  startGUI mfname++startTestBuilder :: FilePath -> IO () +startTestBuilder fname = do +  putStrLn fname+  xojcontent <- read_xojgz fname +  L.writeFile "mytest.xoj" $ builder xojcontent+
+ lib/Application/HXournal/ModelAction/Adjustment.hs view
@@ -0,0 +1,22 @@+module Application.HXournal.ModelAction.Adjustment where++import Graphics.UI.Gtk ++setAdjustments :: (Adjustment,Adjustment) +                  -> (Double,Double) +                  -> (Double,Double)+                  -> (Double,Double) +                  -> (Double,Double)+                  -> IO ()+setAdjustments (hadj,vadj) (upperx,uppery) (lowerx,lowery) (valuex,valuey) (pagex,pagey) = do +    adjustmentSetUpper hadj upperx +    adjustmentSetUpper vadj uppery +    adjustmentSetLower hadj lowerx+    adjustmentSetLower vadj lowery+    adjustmentSetValue hadj valuex+    adjustmentSetValue vadj valuey +    adjustmentSetPageSize hadj pagex+    adjustmentSetPageSize vadj pagey+    ++
+ lib/Application/HXournal/ModelAction/Eraser.hs view
@@ -0,0 +1,13 @@+module Application.HXournal.ModelAction.Eraser where++import Control.Monad.State +import Graphics.Xournal.Type +import Graphics.Xournal.HitTest++eraseHitted :: AlterList NotHitted (AlterList NotHitted Hitted) +               -> State (Maybe BBox) [StrokeBBox]+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
+ lib/Application/HXournal/ModelAction/File.hs view
@@ -0,0 +1,53 @@+module Application.HXournal.ModelAction.File where++import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Canvas+import Application.HXournal.ModelAction.Page+import Graphics.Xournal.Type.Map+import Text.Xournal.Type+import qualified Text.Xournal.Parse as P+import qualified Data.IntMap as M+import Control.Category+import Data.Label+import Prelude hiding ((.),id)++-- | get file content from xournal file and update xournal state ++getFileContent :: Maybe FilePath +               -> HXournalState +               -> IO HXournalState +getFileContent (Just fname) xstate = do +    xojcontent <- P.read_xournal fname +    let currcid = get currentCanvas xstate +        cmap = get canvasInfoMap xstate +    let xojWbbox = mkXournalBBoxMapFromXournal xojcontent +    let Dim width height = pageDim . (!! 0) .  xournalPages $ xojcontent+        startingxojstate = ViewAppendState xojWbbox+        cids = M.keys cmap +        update x _cinfo = +          let changefunc c = +                setPage startingxojstate 0 +                . set viewInfo (ViewInfo OnePage Original (0,0) (width,height))+                . set currentPageNum 0 +                $ c +          in  M.adjust changefunc x cmap  +        cmap' = foldr update cmap cids   +    let newxstate = set xournalstate startingxojstate+                    . set currFileName (Just fname)+                    . set canvasInfoMap cmap'+                    . set currentCanvas currcid +                    $ xstate+    return newxstate +getFileContent Nothing xstate = do   +    let newxoj = mkXournalBBoxMapFromXournal defaultXournal +        newxojstate = ViewAppendState newxoj +        xstate' = set currFileName Nothing +                  . set xournalstate newxojstate+                  $ xstate +        cmap = get canvasInfoMap xstate'+    let Dim w h = pageDim . (!! 0) .  xournalPages $ defaultXournal+        ciupdt = setPage newxojstate 0                       +                 . set viewInfo (ViewInfo OnePage Original (0,0) (w,h))+                 . set currentPageNum 0 +        cmap' = M.map ciupdt cmap+    return (set canvasInfoMap cmap' xstate')
+ lib/Application/HXournal/ModelAction/Page.hs view
@@ -0,0 +1,85 @@+module Application.HXournal.ModelAction.Page where++import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Canvas+import Text.Xournal.Type+import Graphics.Xournal.Type.Map+import Graphics.Xournal.Type.Select+import Control.Category+import Data.Label+import Prelude hiding ((.),id)+import qualified Data.IntMap as M ++updatePageAll :: XournalState +                 -> HXournalState +                 -> HXournalState+updatePageAll xst xstate = let cmap = get canvasInfoMap xstate+                               cmap' = fmap (updatePage xst) cmap+                           in  set canvasInfoMap cmap' xstate +++getPageFromXojBBoxMap :: Int -> XournalBBoxMap -> PageBBoxMap+getPageFromXojBBoxMap pagenum xojbbox  = +  case M.lookup pagenum (xbm_pages xojbbox) of +    Nothing -> error "something wrong in updatePage"+    Just p -> p++updatePage :: XournalState -> CanvasInfo -> CanvasInfo +updatePage (ViewAppendState xojbbox) cinfo = +  let pagenum = get currentPageNum cinfo +      pg = getPageFromXojBBoxMap pagenum xojbbox +      Dim w h = pageDim pg+  in  set currentPageNum pagenum +      . set (pageDimension.viewInfo) (w,h)       +      . set currentPage (Left pg)+      $ cinfo +updatePage (SelectState txoj) cinfo = +  let pagenum = get currentPageNum cinfo+      mspage = tx_selectpage txoj +      pageFromArg = case M.lookup pagenum (tx_pages txoj) of +                      Nothing -> error "no such page in updatePage"+                      Just p -> p+      (newpage,Dim w h) = +        case mspage of +          Nothing -> (Left pageFromArg, pageDim pageFromArg)+          Just (spagenum,page) -> +            if spagenum == pagenum +              then (Right page, tp_dim page) +              else (Left pageFromArg, pageDim pageFromArg)+  in set currentPageNum pagenum +     . set (pageDimension.viewInfo) (w,h)       +     . set currentPage newpage+     $ cinfo +  +setPage :: XournalState -> Int -> CanvasInfo -> CanvasInfo+setPage (ViewAppendState xojbbox) pagenum cinfo = +  let pg = getPageFromXojBBoxMap pagenum xojbbox +      Dim w h = pageDim pg+  in  set currentPageNum pagenum +      . set (viewPortOrigin.viewInfo) (0,0) +      . set (pageDimension.viewInfo) (w,h)       +      . set currentPage (Left pg)+      $ cinfo +setPage (SelectState txoj) pagenum cinfo = +  let mspage = tx_selectpage txoj +      pageFromArg = case M.lookup pagenum (tx_pages txoj) of +                      Nothing -> error "no such page in setPage"+                      Just p -> p+      (newpage,Dim w h) = +        case mspage of +          Nothing -> (Left pageFromArg, pageDim pageFromArg)+          Just (spagenum,page) -> +            if spagenum == pagenum +              then (Right page, tp_dim page) +              else (Left pageFromArg, pageDim pageFromArg)+  in set currentPageNum pagenum +     . set (viewPortOrigin.viewInfo) (0,0) +     . set (pageDimension.viewInfo) (w,h)       +     . set currentPage newpage+     $ cinfo +                            +getPage :: CanvasInfo -> PageBBoxMap+getPage cinfo = case get currentPage cinfo of +                  Right tpgs -> pageBBoxMapFromTempPageSelect tpgs+                  Left pg -> pg +
+ lib/Application/HXournal/ModelAction/Pen.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++module Application.HXournal.ModelAction.Pen where++import Application.HXournal.ModelAction.Page+import Graphics.Xournal.Type+import Graphics.Xournal.Type.Map+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.Enum+import Data.Foldable+import Data.Maybe+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Control.Category+import Data.Sequence hiding (take, drop)+import Data.Label+import Prelude hiding ((.), id)+import Data.Strict.Tuple hiding (uncurry)+import Text.Xournal.Type++addPDraw :: PenInfo -> XournalBBoxMap -> Int -> Seq (Double,Double) +            -> (XournalBBoxMap,BBox)+addPDraw pinfo xoj pgnum pdraw = +  let pcolor = get penColor pinfo+      pcolname = fromJust (M.lookup pcolor penColorNameMap)+      pwidth = get penWidth pinfo+      currpage = getPageFromXojBBoxMap  pgnum xoj+      currlayer = case IM.lookup 0 (pbm_layers currpage) of+                    Nothing -> error "something wrong in addPDraw"+                    Just l -> l+      newstroke = Stroke { stroke_tool = "pen" +                         , stroke_color = pcolname +                         , stroke_width = pwidth+                         , stroke_data = map (uncurry (:!:)) . toList $ pdraw+                         } +      newstrokebbox = mkStrokeBBoxFromStroke newstroke+      newlayerbbox =  currlayer {layerbbox_strokes = layerStrokes currlayer +                                                    ++ [newstrokebbox] }+      newpagebbox = currpage { +        pbm_layers = IM.adjust (const newlayerbbox) 0 (pbm_layers currpage) +      }++      newxojbbox = xoj { +        xbm_pages = IM.adjust (const newpagebbox) pgnum (xbm_pages xoj) +      }+  in  (newxojbbox,strokebbox_bbox newstrokebbox)++
+ lib/Application/HXournal/ModelAction/Select.hs view
@@ -0,0 +1,90 @@+module Application.HXournal.ModelAction.Select where++import Application.HXournal.Type.Enum++import Graphics.Xournal.Type +import Graphics.Xournal.Type.Select+import Graphics.Xournal.HitTest++import Graphics.UI.Gtk hiding (get,set)++import Data.Strict.Tuple+import qualified Data.IntMap as M+import qualified Data.Map as Map +++changeStrokeByOffset :: (Double,Double) -> StrokeBBox -> StrokeBBox +changeStrokeByOffset (offx,offy) (StrokeBBox t c w ds bbox) = +  let offset ( x :!: y )  = (x+offx) :!: (y+offy)+      newds = map offset ds +      BBox (x1,y1) (x2,y2) = bbox +      newbbox = BBox (x1+offx,y1+offy) (x2+offx,y2+offy)+  in  StrokeBBox t c w newds newbbox++changeSelectionByOffset :: TempPageSelect -> (Double,Double) -> TempPageSelect+changeSelectionByOffset tpage off = +  let activelayer = tp_firstlayer tpage +  in case strokes activelayer of +       Left _ -> tpage +       Right alist -> +         let alist' =fmapAL id +                            (Hitted . map (changeStrokeByOffset off) . unHitted) +                            alist +             layer' = LayerSelect (Right alist')+         in tpage { tp_firstlayer = layer' }++updateTempXournalSelect :: TempXournalSelect -> TempPageSelect -> Int +                           -> TempXournalSelect+updateTempXournalSelect txoj tpage pagenum =                +  let pgs = tx_pages txoj +      pgs' = M.adjust (const (pageBBoxMapFromTempPageSelect tpage))+                        pagenum pgs+  in TempXournalSelect pgs' (Just (pagenum,tpage)) +    +    +hitInSelection :: TempPageSelect -> (Double,Double) -> Bool +hitInSelection tpage point = +  let activelayer = tp_firstlayer tpage+  in case strokes activelayer of +       Left _ -> False   +       Right alist -> +         let bboxes = map strokebbox_bbox . takeHittedStrokes $ alist+         in  any (flip hitTestBBoxPoint point) bboxes +    +takeHittedStrokes :: AlterList [StrokeBBox] Hitted -> [StrokeBBox] +takeHittedStrokes = concatMap unHitted . getB ++isAnyHitted :: AlterList [StrokeBBox] Hitted -> Bool +isAnyHitted = not . null . takeHittedStrokes++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 +  in  str { strokebbox_color = cname } +      ++changeStrokeWidth :: Double -> StrokeBBox -> StrokeBBox+changeStrokeWidth pwidth str = str { strokebbox_width = pwidth } +
+ lib/Application/HXournal/ModelAction/Window.hs view
@@ -0,0 +1,141 @@+module Application.HXournal.ModelAction.Window where++import Application.HXournal.Type.Canvas+import Application.HXournal.Type.Event+import Application.HXournal.Type.Window+import Application.HXournal.Type.XournalState+import Application.HXournal.Device+import Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk (set)+import Control.Monad.Trans +import Control.Category+import Data.Label+import Prelude hiding ((.),id)+import qualified Data.IntMap as M+import System.FilePath++setTitleFromFileName :: HXournalState -> IO () +setTitleFromFileName xstate = do +  case get currFileName xstate of+    Nothing -> Gtk.set (get rootOfRootWindow xstate) +                       [ windowTitle := "untitled" ]+    Just filename -> Gtk.set (get rootOfRootWindow xstate) +                             [ windowTitle := takeFileName filename] ++newCanvasId :: CanvasInfoMap -> CanvasId +newCanvasId cmap = +  let cids = M.keys cmap +  in  (maximum cids) + 1  +++initCanvasInfo :: HXournalState -> CanvasId -> IO CanvasInfo +initCanvasInfo xstate cid = do +    let callback = get callBack xstate+        dev = get deviceList xstate +    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 +    +    canvas `on` sizeRequest $ return (Requisition 480 400)    +    canvas `on` buttonPressEvent $ tryEvent $ do +      p <- getPointer dev+      liftIO (callback (PenDown cid p))+    canvas `on` configureEvent $ tryEvent $ do +      (w,h) <- eventSize +      liftIO $ callback -- bouncecallback tref sref +                 (CanvasConfigure cid (fromIntegral w) (fromIntegral h))+    canvas `on` buttonReleaseEvent $ tryEvent $ do +      p <- getPointer dev+      liftIO (callback (PenUp cid p))+    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]      +    widgetSetExtensionEvents canvas [ExtensionEventsAll]++    afterValueChanged hadj $ do +      v <- adjustmentGetValue hadj +      callback (HScrollBarMoved cid v)+    afterValueChanged vadj $ do +      v <- adjustmentGetValue vadj     +      callback (VScrollBarMoved cid v)+    Just vscrbar <- scrolledWindowGetVScrollbar scrwin+    vscrbar `on` buttonPressEvent $ do +      v <- liftIO $ adjustmentGetValue vadj +      liftIO (callback (VScrollBarStart cid v))+      return False+    vscrbar `on` buttonReleaseEvent $ do +      v <- liftIO $ adjustmentGetValue vadj +      liftIO (callback (VScrollBarEnd cid v))+      return False+    return $ CanvasInfo cid canvas scrwin (error "no viewInfo") 0 (error "No page")  hadj vadj +  +constructFrame :: WindowConfig -> CanvasInfoMap -> IO (Widget,WindowConfig)+constructFrame (Node cid) cmap = do +    case (M.lookup cid cmap) of+      Nothing -> error $ "no such cid = " ++ show cid ++ " in constructFrame"+      Just cinfo -> return (castToWidget . get scrolledWindow $ cinfo, Node cid)+constructFrame (HSplit hpane wconf1 wconf2) cmap = do  +    (win1,wconf1') <- constructFrame wconf1 cmap+    (win2,wconf2') <- constructFrame wconf2 cmap +    hpane' <- case hpane of+                Nothing -> hPanedNew +                Just h -> return h+    panedPack1 hpane' win1 True False+    panedPack2 hpane' win2 True False+    widgetShowAll hpane' +    return (castToWidget hpane', HSplit (Just hpane') wconf1' wconf2')+constructFrame (VSplit vpane wconf1 wconf2) cmap = do  +    (win1,wconf1') <- constructFrame wconf1 cmap+    (win2,wconf2') <- constructFrame wconf2 cmap +    vpane' <- case vpane of +                Nothing -> vPanedNew +                Just v -> return v+    panedPack1 vpane' win1 True False+    panedPack2 vpane' win2 True False+    widgetShowAll vpane' +    return (castToWidget vpane', VSplit (Just vpane') wconf1' wconf2')+  +  +removePanes :: WindowConfig -> IO WindowConfig+removePanes n@(Node _) = return n+removePanes (HSplit hpane wconf1 wconf2) = do +    case hpane of +      Just h -> do +        panedGetChild1 h >>= \x -> case x of +          Just c1 -> containerRemove h c1+          Nothing -> return ()+        panedGetChild2 h >>= \x -> case x of +          Just c2 -> containerRemove h c2+          Nothing -> return ()+        widgetDestroy h+      Nothing -> return ()+    wconf1' <- removePanes wconf1   +    wconf2' <- removePanes wconf2 +    return (HSplit Nothing wconf1' wconf2')+removePanes (VSplit vpane wconf1 wconf2) = do +    case vpane of +      Just v -> do +        panedGetChild1 v >>= \x -> case x of +          Just c1 -> containerRemove v c1+          Nothing -> return ()+        panedGetChild2 v >>= \x -> case x of +          Just c2 -> containerRemove v c2+          Nothing -> return ()+        widgetDestroy v+      Nothing -> return ()+    wconf1' <- removePanes wconf1 +    wconf2' <- removePanes wconf2 +    return (VSplit Nothing wconf1' wconf2')  +
+ lib/Application/HXournal/ProgType.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Application.HXournal.ProgType where ++import System.Console.CmdArgs++data Hxournal = Test { xojfile :: Maybe FilePath+                     }  +              deriving (Show,Data,Typeable)++test :: Hxournal+test = Test { xojfile = def &= typ "FILENAME" &= args -- &= argPos 0 &= opt "OPTIONAL" +            } &= auto +++mode :: Hxournal+mode = modes [test] ++
+ lib/Application/HXournal/Type.hs view
@@ -0,0 +1,13 @@+module Application.HXournal.Type +( module Application.HXournal.Type.Event+, module Application.HXournal.Type.Enum+, module Application.HXournal.Type.Canvas+, module Application.HXournal.Type.XournalState+, module Application.HXournal.Type.Coroutine+) where++import Application.HXournal.Type.Event+import Application.HXournal.Type.Enum +import Application.HXournal.Type.Canvas+import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Coroutine
+ lib/Application/HXournal/Type/Canvas.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++module Application.HXournal.Type.Canvas where++import Application.HXournal.Type.Enum +import Data.Sequence+import qualified Data.IntMap as M+import Data.Label +import Prelude hiding ((.), id)+import Graphics.Xournal.Type.Map+import Graphics.Xournal.Type.Select+import Graphics.UI.Gtk hiding (get,set)++type CanvasId = Int ++data PenDraw = PenDraw { _points :: Seq (Double,Double) } +             deriving (Show)+                      +emptyPenDraw :: PenDraw+emptyPenDraw = PenDraw empty++data PageMode = Continous | OnePage+              deriving (Show,Eq) ++data ZoomMode = Original | FitWidth | FitHeight | Zoom Double +              deriving (Show,Eq)++data ViewInfo = ViewInfo { _pageMode :: PageMode+                         , _zoomMode :: ZoomMode+                         , _viewPortOrigin :: (Double,Double)+                         , _pageDimension :: (Double,Double) +                         }+                deriving (Show)++data CanvasInfo = CanvasInfo { _canvasId :: CanvasId+                             , _drawArea :: DrawingArea+                             , _scrolledWindow :: ScrolledWindow+                             , _viewInfo :: ViewInfo +                             , _currentPageNum :: Int+                             , _currentPage :: Either PageBBoxMap TempPageSelect +                             , _horizAdjustment :: Adjustment+                             , _vertAdjustment :: Adjustment +                             }+++type CanvasInfoMap = M.IntMap CanvasInfo++data PenType = PenWork +             | HighlighterWork +             | EraserWork +             | TextWork +             deriving (Show,Eq)++data PenInfo = PenInfo { _penType :: PenType+                       , _penWidth :: Double+                       , _penColor :: PenColor } +             deriving (Show) +++$(mkLabels [''PenDraw, ''ViewInfo, ''PenInfo, ''CanvasInfo])+
+ lib/Application/HXournal/Type/Clipboard.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}++module Application.HXournal.Type.Clipboard +--       ( Clipboard+--       , emptyClipboard+--       , isEmpty+--       , getClipContents +--       , replaceClipContents+--       ) +  where++import Control.Category+import Data.Label +import Prelude hiding ((.), id)++import Graphics.Xournal.Type++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) ++data SelectInfo = SelectInfo { _selectType :: SelectType+                             }+             deriving (Show) ++$(mkLabels [''SelectInfo])+
+ lib/Application/HXournal/Type/Coroutine.hs view
@@ -0,0 +1,17 @@+module Application.HXournal.Type.Coroutine where++import Data.IORef +import Application.HXournal.Type.Event+import Application.HXournal.Type.XournalState +import Control.Monad.Coroutine +import Control.Monad.Coroutine.SuspensionFunctors+import Data.Functor.Identity (Identity(..))++type Trampoline m x = Coroutine Identity m x +type Generator a m x = Coroutine (Yield a) m x+type Iteratee a m x = Coroutine (Await a) m x++type SusAwait =  Await MyEvent (Iteratee MyEvent XournalStateIO ())+type TRef = IORef SusAwait +type SRef = IORef HXournalState+
+ lib/Application/HXournal/Type/Enum.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Application.HXournal.Type.Enum where++import qualified Data.ByteString.Char8 as B+import qualified Data.Map as M+import Data.Maybe ++import Text.Xournal.Predefined++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)+
+ lib/Application/HXournal/Type/Event.hs view
@@ -0,0 +1,104 @@+module Application.HXournal.Type.Event where++import Application.HXournal.Type.Enum+import Application.HXournal.Device ++data MyEvent = Initialized+             | CanvasConfigure Int Double Double +             | UpdateCanvas Int+             | PenDown Int PointerCoord+             | PenMove Int PointerCoord+             | PenUp   Int PointerCoord +             | PenColorChanged PenColor+             | PenWidthChanged Double +             | HScrollBarMoved Int Double+             | VScrollBarMoved Int Double +             | VScrollBarStart Int Double+             | VScrollBarEnd   Int Double+             | ToViewAppendMode+             | ToSelectMode+             | Menu MenuEvent +             deriving (Show,Eq,Ord)+++data MenuEvent = MenuNew +               | MenuAnnotatePDF+               | MenuOpen +               | MenuSave+               | MenuSaveAs+               | MenuRecentDocument+               | MenuPrint +               | MenuExport +               | MenuQuit +               | MenuUndo +               | MenuRedo +               | MenuCut +               | MenuCopy +               | MenuPaste +               | MenuDelete+               | MenuFullScreen +               | MenuZoom +               | MenuZoomIn+               | MenuZoomOut +               | MenuNormalSize+               | MenuPageWidth+               | MenuPageHeight+               | MenuSetZoom+               | MenuFirstPage+               | MenuPreviousPage +               | MenuNextPage +               | MenuLastPage +               | MenuShowLayer+               | MenuHideLayer+               | MenuHSplit  +               | MenuVSplit+               | MenuDelCanvas+               | MenuNewPageBefore+               | MenuNewPageAfter +               | MenuNewPageAtEnd +               | MenuDeletePage+               | MenuNewLayer+               | MenuDeleteLayer+               | MenuPaperSize+               | MenuPaperColor+               | MenuPaperStyle +               | MenuApplyToAllPages +               | MenuLoadBackground+               | MenuBackgroundScreenshot +               | MenuDefaultPaper+               | MenuSetAsDefaultPaper+               | MenuShapeRecognizer+               | MenuRuler+               | MenuSelectRegion+               | MenuSelectRectangle+               | MenuVerticalSpace+               | MenuHandTool+               | MenuPenOptions+               | MenuEraserOptions +               | MenuHighlighterOptions+               | MenuTextFont+               | MenuDefaultPen +               | MenuDefaultEraser +               | MenuDefaultHighlighter+               | MenuDefaultText +               | MenuSetAsDefaultOption+               | MenuUseXInput+               | MenuDiscardCoreEvents +               | MenuEraserTip +               | MenuPressureSensitivity+               | MenuPageHighlight+               | MenuMultiplePageView+               | MenuMultiplePages+               | MenuButton2Mapping+               | MenuButton3Mapping +               | MenuAntialiasedBitmaps+               | MenuProgressiveBackgrounds+               | MenuPrintPaperRuling +               | MenuLeftHandedScrollbar+               | MenuShortenMenus+               | MenuAutoSavePreferences+               | MenuSavePreferences+               | MenuAbout+               | MenuDefault+               deriving (Show, Ord, Eq)+
+ lib/Application/HXournal/Type/Window.hs view
@@ -0,0 +1,79 @@+module Application.HXournal.Type.Window where++import Application.HXournal.Type.Canvas++import Graphics.UI.Gtk hiding (get,set)++data WindowConfig = Node CanvasId +                  | HSplit (Maybe HPaned) WindowConfig WindowConfig+                  | VSplit (Maybe VPaned) WindowConfig WindowConfig ++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 Nothing (Node cid) (Node cidnew))+           SplitVertical -> Right (VSplit Nothing (Node cid) (Node cidnew))+    else Left (Node cid)+splitWindow cidold (cidnew,stype) (HSplit hpane 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 hpane nwconf1 nwconf2)+        (Left nwconf1, Right nwconf2) -> Right (HSplit hpane nwconf1 nwconf2)+        (Right nwconf1, Left nwconf2) -> Right (HSplit hpane nwconf1 nwconf2)+        (Right _, Right _) -> error "such case cannot happen in splitWindow"+splitWindow cidold (cidnew,stype) (VSplit vpane 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 vpane nwconf1 nwconf2)+        (Left nwconf1, Right nwconf2) -> Right (VSplit vpane nwconf1 nwconf2)+        (Right nwconf1, Left nwconf2) -> Right (VSplit vpane 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 hpane wconf1 wconf2) =+  let r1 = removeWindow cid wconf1+      r2 = removeWindow cid wconf2+  in  case (r1,r2) of +        (Left nwconf1, Left nwconf2) -> Left (HSplit hpane nwconf1 nwconf2)+        (Left nwconf1, Right mnwconf2) -> +          case mnwconf2 of +            Just nwconf2 -> Right (Just (HSplit hpane nwconf1 nwconf2))+            Nothing -> Right (Just nwconf1)+        (Right mnwconf1, Left nwconf2) -> +          case mnwconf1 of+            Just nwconf1 -> Right (Just (HSplit hpane nwconf1 nwconf2))+            Nothing -> Right (Just nwconf2)+        (Right _, Right _) -> error "such case cannot happen in removeWindow"+removeWindow cid (VSplit vpane wconf1 wconf2) =+  let r1 = removeWindow cid wconf1+      r2 = removeWindow cid wconf2+  in  case (r1,r2) of +        (Left nwconf1, Left nwconf2) -> Left (VSplit vpane nwconf1 nwconf2)+        (Left nwconf1, Right mnwconf2) -> +          case mnwconf2 of +            Just nwconf2 -> Right (Just (VSplit vpane nwconf1 nwconf2))+            Nothing -> Right (Just nwconf1)+        (Right mnwconf1, Left nwconf2) -> +          case mnwconf1 of+            Just nwconf1 -> Right (Just (VSplit vpane nwconf1 nwconf2))+            Nothing -> Right (Just nwconf2)+        (Right _, Right _) -> error "such case cannot happen in removeWindow"+
+ lib/Application/HXournal/Type/XournalState.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}++module Application.HXournal.Type.XournalState where++import Application.HXournal.Device+import Application.HXournal.Type.Event +import Application.HXournal.Type.Enum+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.Clipboard+import Application.HXournal.Type.Window +import Graphics.Xournal.Type.Select+import Graphics.Xournal.Type.Map+import Control.Monad.State+import Text.Xournal.Type+import Text.Xournal.Predefined +import Graphics.UI.Gtk hiding (Clipboard)+import Data.Maybe+import Data.Label +import Prelude hiding ((.), id)++type XournalStateIO = StateT HXournalState IO ++data XournalState = ViewAppendState { unView :: XournalBBoxMap }+                  | SelectState { tempSelect :: TempXournalSelect }++data HXournalState = HXournalState { _xournalstate :: XournalState+                                   , _currFileName :: Maybe FilePath+                                   , _canvasInfoMap :: CanvasInfoMap +                                   , _currentCanvas :: Int+                                   , _frameState :: WindowConfig +                                   , _rootWindow :: Widget+                                   , _rootContainer :: Box+                                   , _rootOfRootWindow :: Window+                                   , _currentPenDraw :: PenDraw+                                   , _clipboard :: Clipboard+                                   , _callBack ::  MyEvent -> IO ()+                                   , _deviceList :: DeviceList+                                   , _penInfo :: PenInfo+                                   , _selectInfo :: SelectInfo +                                   , _gtkUIManager :: UIManager +                                   } +++$(mkLabels [''HXournalState]) ++emptyHXournalState :: HXournalState +emptyHXournalState = +  HXournalState  +  { _xournalstate = ViewAppendState (mkXournalBBoxMapFromXournal emptyXournal)+  , _currFileName = Nothing +  , _canvasInfoMap = error "emptyHXournalState.canvasInfoMap"+  , _currentCanvas = error "emtpyHxournalState.currentCanvas"+  , _frameState = error "emptyHXournalState.frameState" +  , _rootWindow = error "emtpyHXournalState.rootWindow"+  , _rootContainer = error "emptyHXournalState.rootContainer"+  , _rootOfRootWindow = error "emptyHXournalState.rootOfRootWindow"+  , _currentPenDraw = emptyPenDraw +  , _clipboard = emptyClipboard+  , _callBack = error "emtpyHxournalState.callBack"+  , _deviceList = error "emtpyHxournalState.deviceList"+  , _penInfo = PenInfo PenWork predefined_medium ColorBlack+  , _selectInfo = SelectInfo SelectRectangleWork +  , _gtkUIManager = error "emptyHXournalState.gtkUIManager"+  }++
+ lib/Application/HXournal/Util.hs view
@@ -0,0 +1,20 @@+module Application.HXournal.Util where++import Text.Xournal.Type++getLargestWidth :: Xournal -> Double +getLargestWidth xoj = +  let ws = map (dim_width . page_dim) (xoj_pages xoj)  +  in  maximum ws ++getLargestHeight :: Xournal -> Double +getLargestHeight xoj = +  let hs = map (dim_height . page_dim) (xoj_pages xoj)  +  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
+ lib/Application/HXournal/Util/Verbatim.hs view
@@ -0,0 +1,15 @@+module Application.HXournal.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+--           } +
+ 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)

+ template/index.html.st view
@@ -0,0 +1,8 @@+<html>+  <head>+    <title> XOJ file </title>+  </head>+  <body>+    $body$+  </body>+</html>