gtk3 / gtk2hs:在滚动的窗口中摇摄“闪烁”

时间:2015-05-04 16:09:53

标签: haskell gtk3 panning gtk2hs

我正在尝试在gtk3 / gtk2hs中的滚动窗口上获得平移行为,类似于谷歌地图的地图显示(我被告知它被称为平移,但标签描述将其定义为旋转)

(scrollledWindow中的光标,M1向下)=>滚动窗口中的对象“跟随”鼠标光标

一般的想法是在buttonPressEvent上记录光标位置,并在motionNotifyEvent上使用偏移到当前位置来更新视口的调整。

而不是平滑地跟随,我得到闪烁的行为,导致图像来回跳跃而不是以正确的“速度”(比例偏移)跟随。 下面的代码包括我的调试尝试。打印显示onMotionNotify部分使用“不正确”的光标位置执行。

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

其中target是滚动窗口中的视口,它本身包含带图像的叠加层:

  • scrolledWindow
  • 覆盖
  • 图像

按下并沿一个方向缓慢拖动时的典型输出如下所示:

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      

标记的线条是我称之为“跳跃”的一个例子 似乎事件被处理了两次,但仍然无法解释为什么窗口小部件移动明显慢于鼠标移动。

修改

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 这3个文件+一个名为“redCat.jpg”的大图像应该在cabal沙箱中使用:

cabal sandbox init

cabal install - 仅依赖于

cabal run

1 个答案:

答案 0 :(得分:1)

你的问题是由于在你还在聆听运动事件的同时继续扯动视口这一事实造成的。

我发现的简单解决方案是将scrolledWindow包裹在GtkEventBox中(我已在我的代码中调用eventbox),然后将事件监听器附加到该代码中。这样,您正在侦听的小部件就不会移动(它是固定的GtkEventBox)。

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

initViewportPanning稍微改变以允许与其目标不同的事件源:

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

我正以这种方式顺利平滑。