haskellgtk3panninggtk2hs

gtk3/gtk2hs: panning in a scrolledWindow "flickers"

I'm trying to get panning behavior on a scrolledWindow in gtk3/gtk2hs similar to a map display like google maps (i was told it's called panning, but the tag description defines it as rotation)

(Cursor in scrolledWindow, M1 down) => object in scrolledwindow "follows" mouse cursor

The general idea is to record the cursor position on buttonPressEvent and, on motionNotifyEvent, use the offset to the current position to update the Adjustment of the viewport.

Instead of following smoothly, i get flickering behavior that causes the image to jump back and forth and not follow at the correct "speed" (proportional offset). The code below includes my attempts at debugging. The prints show that the onMotionNotify part is executed with "incorrect" cursor positions.

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 Control.Monad.IO.Class(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

where target is the viewport in a scrolledwindow and itself contains an overlay with an image:

Typical output upon pressing and slowly dragging in one direction looks like this:

pressed
motion at 629.247802734375 , 581.4336242675781
motion at 629.247802734375 , 582.4336242675781    
motion at 629.247802734375 , 580.4336242675781    # 
motion at 628.247802734375 , 582.4336242675781    #
motion at 629.247802734375 , 579.4336242675781    # 
motion at 627.247802734375 , 582.4336242675781
motion at 629.247802734375 , 578.4336242675781

The marked lines are an example of what i refer to as "jumps" It seems as if the event was handled twice, but that still does not explain why the widget movement is significantly slower than mouse movement.

Edit:

XML: "main.ui"

<?xml version="1.0" encoding="UTF-8"?>
<!-- Generated with glade 3.16.1 -->
<interface>
  <requires lib="gtk+" version="3.10"/>
  <object class="GtkApplicationWindow" id="mainWindow">
    <property name="width_request">600</property>
    <property name="height_request">400</property>
    <property name="can_focus">False</property>
    <property name="window_position">center-on-parent</property>
    <child>
      <object class="GtkScrolledWindow" id="scrolledWindow">
        <property name="visible">True</property>
        <property name="can_focus">True</property>
        <property name="shadow_type">in</property>
        <child>
          <object class="GtkViewport" id="viewport">
            <property name="visible">True</property>
            <property name="can_focus">False</property>
            <child>
              <object class="GtkOverlay" id="overlay">
                <property name="visible">True</property>
                <property name="sensitive">False</property>
                <property name="can_focus">False</property>
                <property name="hexpand">True</property>
                <property name="vexpand">True</property>
                <child>
                  <placeholder/>
                </child>
              </object>
            </child>
          </object>
        </child>
      </object>
    </child>
  </object>
  <object class="GtkSizeGroup" id="sizegroup1">
    <property name="mode">both</property>
    <widgets>
      <widget name="mainWindow"/>
    </widgets>
  </object>
</interface>

http://pastebin.com/pmCS1HDr

.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, 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 Control.Monad.IO.Class(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

http://pastebin.com/QKbPuNKe these 3 files + a large image called "redCat.jpg" should work in a cabal sandbox using:

cabal sandbox init

cabal install --dependencies-only

cabal run

Solution

  • Your problem is caused by the fact that you keep yanking the viewport around while you are also listening to motion events on it.

    The simple solution I've found is to wrap your scrolledWindow in a GtkEventBox (I've called in eventbox in my code) and then attach the event listener to that. This way, the widget you are listening on doesn't move around (it's the fixed GtkEventBox).

    eventbox <- builderGetObject builder castToEventBox "eventbox"
viewport <- builderGetObject builder castToViewport "viewport"
initViewportPanning eventbox viewport

    with initViewportPanning changed slightly to allow a different event source than its target:

    initViewportPanning :: (WidgetClass src, ViewportClass target)
                    => src -> target -> IO (ConnectId src)
initViewportPanning src target = do
    widgetAddEvents src [Button1MotionMask]
    -- ...
    on src buttonPressEvent $ do
      -- unchanged
    on src motionNotifyEvent $ do
      -- unchanged

    I'm getting silky-smooth panning this way.