diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2011, Ian-Woo Kim. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,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 +> -- } diff --git a/csrc/c_initdevice.c b/csrc/c_initdevice.c new file mode 100644 --- /dev/null +++ b/csrc/c_initdevice.c @@ -0,0 +1,58 @@ +#include +#include +#include + +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); +//} diff --git a/csrc/c_initdevice.h b/csrc/c_initdevice.h new file mode 100644 --- /dev/null +++ b/csrc/c_initdevice.h @@ -0,0 +1,6 @@ +#include +#include + +void initdevice( int*, int*, int* ); + +//void extEventCanvas( void* ); diff --git a/exe/hxournal.hs b/exe/hxournal.hs new file mode 100644 --- /dev/null +++ b/exe/hxournal.hs @@ -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 diff --git a/hxournal.cabal b/hxournal.cabal new file mode 100644 --- /dev/null +++ b/hxournal.cabal @@ -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 +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 + + diff --git a/lib/Application/HXournal/Accessor.hs b/lib/Application/HXournal/Accessor.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Accessor.hs @@ -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)) diff --git a/lib/Application/HXournal/Builder.hs b/lib/Application/HXournal/Builder.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Builder.hs @@ -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 "\n\n" + <> fromTitle (xoj_title xoj) <> mconcat (map fromPage (xoj_pages xoj)) + <> fromByteString "\n" + +fromTitle :: S.ByteString -> Builder +fromTitle title = fromByteString "" + <> fromByteString title + <> fromByteString "\n" + + +fromPage :: Page -> Builder +fromPage page = fromByteString " fromByteString (toFixed 2 w) + <> fromByteString "\" height=\"" + <> fromByteString (toFixed 2 h) + <> fromByteString "\">\n" + <> fromBackground (page_bkg page) + <> mconcat (map fromLayer (page_layers page)) + <> fromByteString "\n" + where Dim w h = page_dim page + +fromBackground :: Background -> Builder +fromBackground bkg = fromByteString " fromByteString (bkg_type bkg) + <> fromByteString "\" color=\"" + <> fromByteString (bkg_color bkg) + <> fromByteString "\" style=\"" + <> fromByteString (bkg_style bkg) + <> fromByteString "\"/>\n" + + +fromLayer :: Layer -> Builder +fromLayer layer = fromByteString "\n" + <> mconcat (map fromStroke (layer_strokes layer)) + <> fromByteString "\n" + +fromStroke :: Stroke -> Builder +fromStroke stroke = fromByteString " 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\n" + +fromCoord :: Pair Double Double -> Builder +fromCoord (x :!: y) = fromByteString (toFixed 2 x) + <> fromChar ' ' + <> fromByteString (toFixed 2 y) + <> fromChar ' ' diff --git a/lib/Application/HXournal/Command.hs b/lib/Application/HXournal/Command.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Command.hs @@ -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 + diff --git a/lib/Application/HXournal/Coroutine.hs b/lib/Application/HXournal/Coroutine.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine.hs @@ -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 + diff --git a/lib/Application/HXournal/Coroutine/Callback.hs b/lib/Application/HXournal/Coroutine/Callback.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Callback.hs @@ -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 () + diff --git a/lib/Application/HXournal/Coroutine/Default.hs b/lib/Application/HXournal/Coroutine/Default.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Default.hs @@ -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 diff --git a/lib/Application/HXournal/Coroutine/Draw.hs b/lib/Application/HXournal/Coroutine/Draw.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Draw.hs @@ -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 + diff --git a/lib/Application/HXournal/Coroutine/Eraser.hs b/lib/Application/HXournal/Coroutine/Eraser.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Eraser.hs @@ -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 () + diff --git a/lib/Application/HXournal/Coroutine/EventConnect.hs b/lib/Application/HXournal/Coroutine/EventConnect.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/EventConnect.hs @@ -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))) diff --git a/lib/Application/HXournal/Coroutine/File.hs b/lib/Application/HXournal/Coroutine/File.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/File.hs @@ -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 () + + + diff --git a/lib/Application/HXournal/Coroutine/Highlighter.hs b/lib/Application/HXournal/Coroutine/Highlighter.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Highlighter.hs @@ -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" + diff --git a/lib/Application/HXournal/Coroutine/Mode.hs b/lib/Application/HXournal/Coroutine/Mode.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Mode.hs @@ -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 () diff --git a/lib/Application/HXournal/Coroutine/Page.hs b/lib/Application/HXournal/Coroutine/Page.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Page.hs @@ -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 + diff --git a/lib/Application/HXournal/Coroutine/Pen.hs b/lib/Application/HXournal/Coroutine/Pen.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Pen.hs @@ -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) diff --git a/lib/Application/HXournal/Coroutine/Scroll.hs b/lib/Application/HXournal/Coroutine/Scroll.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Scroll.hs @@ -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 () + + diff --git a/lib/Application/HXournal/Coroutine/Select.hs b/lib/Application/HXournal/Coroutine/Select.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Select.hs @@ -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 + diff --git a/lib/Application/HXournal/Coroutine/Window.hs b/lib/Application/HXournal/Coroutine/Window.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Coroutine/Window.hs @@ -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) + diff --git a/lib/Application/HXournal/Device.hsc b/lib/Application/HXournal/Device.hsc new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Device.hsc @@ -0,0 +1,127 @@ +{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} + +#include +#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) + diff --git a/lib/Application/HXournal/Draw.hs b/lib/Application/HXournal/Draw.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Draw.hs @@ -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 + + + + + + + diff --git a/lib/Application/HXournal/GUI.hs b/lib/Application/HXournal/GUI.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/GUI.hs @@ -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 () + diff --git a/lib/Application/HXournal/GUI/Menu.hs b/lib/Application/HXournal/GUI/Menu.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/GUI/Menu.hs @@ -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| + + + + + + + + + +|] + +uiDecl :: String +uiDecl = [verbatim| + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +|] + +iconList :: [ (String,String) ] +iconList = [ ("fullscreen.png" , "myfullscreen") + , ("pencil.png" , "mypen") + , ("eraser.png" , "myeraser") + , ("highlighter.png", "myhighlighter") + , ("text-tool.png" , "mytext") + , ("shapes.png" , "myshapes") + , ("ruler.png" , "myruler") + , ("lasso.png" , "mylasso") + , ("rect-select.png", "myrectselect") + , ("stretch.png" , "mystretch") + , ("hand.png" , "myhand") + , ("recycled.png" , "mydefault") + , ("default-pen.png", "mydefaultpen") + , ("thin.png" , "mythin") + , ("medium.png" , "mymedium") + , ("thick.png" , "mythick") + , ("black.png" , "myblack") + , ("blue.png" , "myblue") + , ("red.png" , "myred") + , ("green.png" , "mygreen") + , ("gray.png" , "mygray") + , ("lightblue.png" , "mylightblue") + , ("lightgreen.png" , "mylightgreen") + , ("magenta.png" , "mymagenta") + , ("orange.png" , "myorange") + , ("yellow.png" , "myyellow") + , ("white.png" , "mywhite") + ] + +viewmods :: [RadioActionEntry] +viewmods = [ RadioActionEntry "CONTA" "Continuous" Nothing Nothing Nothing 0 + , RadioActionEntry "ONEPAGEA" "One Page" Nothing Nothing Nothing 1 + ] + +pointmods :: [RadioActionEntry] +pointmods = [ RadioActionEntry "PENVERYFINEA" "Very fine" Nothing Nothing Nothing 0 + , RadioActionEntry "PENFINEA" "Fine" (Just "mythin") Nothing Nothing 1 + + , RadioActionEntry "PENTHICKA" "Thick" (Just "mythick") Nothing Nothing 3 + , RadioActionEntry "PENVERYTHICKA" "Very Thick" Nothing Nothing Nothing 4 + , RadioActionEntry "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" diff --git a/lib/Application/HXournal/Job.hs b/lib/Application/HXournal/Job.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Job.hs @@ -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 + diff --git a/lib/Application/HXournal/ModelAction/Adjustment.hs b/lib/Application/HXournal/ModelAction/Adjustment.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/Adjustment.hs @@ -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 + + + diff --git a/lib/Application/HXournal/ModelAction/Eraser.hs b/lib/Application/HXournal/ModelAction/Eraser.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/Eraser.hs @@ -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 diff --git a/lib/Application/HXournal/ModelAction/File.hs b/lib/Application/HXournal/ModelAction/File.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/File.hs @@ -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') diff --git a/lib/Application/HXournal/ModelAction/Page.hs b/lib/Application/HXournal/ModelAction/Page.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/Page.hs @@ -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 + diff --git a/lib/Application/HXournal/ModelAction/Pen.hs b/lib/Application/HXournal/ModelAction/Pen.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/Pen.hs @@ -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) + + diff --git a/lib/Application/HXournal/ModelAction/Select.hs b/lib/Application/HXournal/ModelAction/Select.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/Select.hs @@ -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 } + diff --git a/lib/Application/HXournal/ModelAction/Window.hs b/lib/Application/HXournal/ModelAction/Window.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ModelAction/Window.hs @@ -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') + diff --git a/lib/Application/HXournal/ProgType.hs b/lib/Application/HXournal/ProgType.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/ProgType.hs @@ -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] + + diff --git a/lib/Application/HXournal/Type.hs b/lib/Application/HXournal/Type.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type.hs @@ -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 diff --git a/lib/Application/HXournal/Type/Canvas.hs b/lib/Application/HXournal/Type/Canvas.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/Canvas.hs @@ -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]) + diff --git a/lib/Application/HXournal/Type/Clipboard.hs b/lib/Application/HXournal/Type/Clipboard.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/Clipboard.hs @@ -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]) + diff --git a/lib/Application/HXournal/Type/Coroutine.hs b/lib/Application/HXournal/Type/Coroutine.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/Coroutine.hs @@ -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 + diff --git a/lib/Application/HXournal/Type/Enum.hs b/lib/Application/HXournal/Type/Enum.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/Enum.hs @@ -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) + diff --git a/lib/Application/HXournal/Type/Event.hs b/lib/Application/HXournal/Type/Event.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/Event.hs @@ -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) + diff --git a/lib/Application/HXournal/Type/Window.hs b/lib/Application/HXournal/Type/Window.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/Window.hs @@ -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" + diff --git a/lib/Application/HXournal/Type/XournalState.hs b/lib/Application/HXournal/Type/XournalState.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Type/XournalState.hs @@ -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" + } + + diff --git a/lib/Application/HXournal/Util.hs b/lib/Application/HXournal/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Util.hs @@ -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 diff --git a/lib/Application/HXournal/Util/Verbatim.hs b/lib/Application/HXournal/Util/Verbatim.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Util/Verbatim.hs @@ -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 +-- } + diff --git a/resource/black.png b/resource/black.png new file mode 100644 Binary files /dev/null and b/resource/black.png differ diff --git a/resource/blue.png b/resource/blue.png new file mode 100644 Binary files /dev/null and b/resource/blue.png differ diff --git a/resource/default-pen.png b/resource/default-pen.png new file mode 100644 Binary files /dev/null and b/resource/default-pen.png differ diff --git a/resource/eraser.png b/resource/eraser.png new file mode 100644 Binary files /dev/null and b/resource/eraser.png differ diff --git a/resource/fullscreen.png b/resource/fullscreen.png new file mode 100644 Binary files /dev/null and b/resource/fullscreen.png differ diff --git a/resource/gray.png b/resource/gray.png new file mode 100644 Binary files /dev/null and b/resource/gray.png differ diff --git a/resource/green.png b/resource/green.png new file mode 100644 Binary files /dev/null and b/resource/green.png differ diff --git a/resource/hand.png b/resource/hand.png new file mode 100644 Binary files /dev/null and b/resource/hand.png differ diff --git a/resource/highlighter.png b/resource/highlighter.png new file mode 100644 Binary files /dev/null and b/resource/highlighter.png differ diff --git a/resource/lasso.png b/resource/lasso.png new file mode 100644 Binary files /dev/null and b/resource/lasso.png differ diff --git a/resource/lightblue.png b/resource/lightblue.png new file mode 100644 Binary files /dev/null and b/resource/lightblue.png differ diff --git a/resource/lightgreen.png b/resource/lightgreen.png new file mode 100644 Binary files /dev/null and b/resource/lightgreen.png differ diff --git a/resource/magenta.png b/resource/magenta.png new file mode 100644 Binary files /dev/null and b/resource/magenta.png differ diff --git a/resource/medium.png b/resource/medium.png new file mode 100644 Binary files /dev/null and b/resource/medium.png differ diff --git a/resource/orange.png b/resource/orange.png new file mode 100644 Binary files /dev/null and b/resource/orange.png differ diff --git a/resource/pencil.png b/resource/pencil.png new file mode 100644 Binary files /dev/null and b/resource/pencil.png differ diff --git a/resource/rect-select.png b/resource/rect-select.png new file mode 100644 Binary files /dev/null and b/resource/rect-select.png differ diff --git a/resource/recycled.png b/resource/recycled.png new file mode 100644 Binary files /dev/null and b/resource/recycled.png differ diff --git a/resource/red.png b/resource/red.png new file mode 100644 Binary files /dev/null and b/resource/red.png differ diff --git a/resource/ruler.png b/resource/ruler.png new file mode 100644 Binary files /dev/null and b/resource/ruler.png differ diff --git a/resource/shapes.png b/resource/shapes.png new file mode 100644 Binary files /dev/null and b/resource/shapes.png differ diff --git a/resource/stretch.png b/resource/stretch.png new file mode 100644 Binary files /dev/null and b/resource/stretch.png differ diff --git a/resource/text-tool.png b/resource/text-tool.png new file mode 100644 Binary files /dev/null and b/resource/text-tool.png differ diff --git a/resource/thick.png b/resource/thick.png new file mode 100644 Binary files /dev/null and b/resource/thick.png differ diff --git a/resource/thin.png b/resource/thin.png new file mode 100644 Binary files /dev/null and b/resource/thin.png differ diff --git a/resource/white.png b/resource/white.png new file mode 100644 Binary files /dev/null and b/resource/white.png differ diff --git a/resource/xournal.png b/resource/xournal.png new file mode 100644 Binary files /dev/null and b/resource/xournal.png differ diff --git a/resource/yellow.png b/resource/yellow.png new file mode 100644 Binary files /dev/null and b/resource/yellow.png differ diff --git a/template/index.html.st b/template/index.html.st new file mode 100644 --- /dev/null +++ b/template/index.html.st @@ -0,0 +1,8 @@ + + + XOJ file + + + $body$ + +