panningMinimal

.cabal
-- Initial panningMinimal.cabal generated by cabal init.  For further
-- documentation, see http://haskell.org/cabal/users-guide/

name:                panningMinimal
version:             0.1.0.0
-- synopsis:
-- description:
-- license:
license-file:        LICENSE
author:              .
maintainer:          .
-- copyright:
-- category:
build-type:          Simple
-- extra-source-files:
cabal-version:       >=1.10

executable panningMinimal
  main-is:             Main.hs
  -- other-modules:
  other-extensions:    PackageImports, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleInstances
  build-depends:       base >=4.6 && <4.7, gtk3, cgi >= 3001.2.2.0, cairo      >= 0.13.0.2, transformers >= 0.4.2.0, mtl >= 2.2.1
  -- hs-source-dirs:
  default-language:    Haskell2010




Main.hs

{-# LANGUAGE PackageImports #-}
module Main where

import Control.Monad
import "gtk3" Graphics.UI.Gtk
import "gtk3" Graphics.UI.Gtk.Buttons.Button
import "gtk3" Graphics.UI.Gtk.General.Enums
import Network.CGI(liftIO)
import WidgetBehavior

main = do
        initGUI

        builder <- builderNew
        builderAddFromFile builder "main.ui"

        window <- builderGetObject builder castToWindow "mainWindow"

        overlay <- builderGetObject builder castToOverlay "overlay"
        viewport <- builderGetObject builder castToViewport "viewport"
        scrolledWindow <- builderGetObject builder castToScrolledWindow "scrolledWindow"

        initViewportPanning viewport
        image <- imageNewFromFile "redCat.jpg"

        containerAdd overlay image
        set overlay [widgetOpacity := 0.9]

        window `on` deleteEvent $ liftIO mainQuit >> return False

        -- Display the window
        widgetShowAll window
        mainGUI

WidgetBehavior.hs

{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PackageImports #-}

module WidgetBehavior where

import Control.Monad
import "gtk3" Graphics.UI.Gtk
import "gtk3" Graphics.UI.Gtk.Buttons.Button
import "gtk3" Graphics.UI.Gtk.General.Enums
import "gtk3" Graphics.UI.Gtk.Gdk.EventM
import Network.CGI(liftIO, MonadIO)
import Control.Monad.State.Class
import Control.Monad.Trans.Reader
import Data.IORef
import Control.Applicative
import Control.Monad.Trans.Class

initViewportPanning :: (WidgetClass target, ViewportClass target) => target -> IO (ConnectId target)
initViewportPanning target = do
    widgetAddEvents target [Button1MotionMask]
    initialCursorPosition <-newIORef (0, 0)
    initialAdjustment <-newIORef (0, 0)
    on target buttonPressEvent $ do
        newPos <- eventCoordinates
        liftIO $ do
            writeIORef initialCursorPosition newPos
            hAdj <- viewportGetHAdjustment target
            hVal <- adjustmentGetValue hAdj
            vAdj <- viewportGetVAdjustment target
            vVal <- adjustmentGetValue vAdj
            writeIORef initialAdjustment (hVal, vVal)
        liftIO $ putStrLn "pressed"
        return True
    on target motionNotifyEvent $ do
        (newH, newV) <- eventCoordinates
        liftIO $ do
            putStrLn ("motion at " ++ show newH ++ " , "++ show newV)
            hAdj <- viewportGetHAdjustment target
            vAdj <- viewportGetVAdjustment target
            (initAdjH, initAdjV) <- readIORef initialAdjustment
            (initCH, initCV) <- readIORef initialCursorPosition

            adjustmentSetValue hAdj (initAdjH - (newH - initCH) )
            adjustmentSetValue vAdj (initAdjV - (newV - initCV) )

            adjustmentValueChanged hAdj
            adjustmentValueChanged vAdj
            return False