Haskell gtk3/gtk2hs：在滚动窗口中平移；闪烁“；

我试图在gtk3/gtk2hs中的滚动窗口上获得类似于谷歌地图这样的地图显示的平移行为（我被告知这称为平移，但标记描述将其定义为旋转）

（滚动窗口中的光标，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

标记的线条是我所说的“跳跃”的一个例子 似乎事件被处理了两次，但这仍然不能解释为什么小部件的移动明显比鼠标的移动慢

编辑：

XML：“main.ui”

600
400
假的
以家长为中心
真的
真的
在里面
真的
假的
真的
假的
假的
真的
真的
二者都

阴谋集团

-- 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

——由cabal init生成的初始panningMinimal.cabal。进一步
--文档，请参阅http://haskell.org/cabal/users-guide/
名称：panningMinimal
版本：0.1.0.0
--简介:
--说明：
--许可证：
许可证文件：许可证
作者：。
维护者：。
--版权所有：
--类别：
构建类型：简单
--额外源文件：
阴谋集团版本：>=1.10
可执行平移最小值
main是：main.hs
--其他模块：
其他扩展：PackageImports、MultiparamTypeClass、GeneralizedNewtypeDeriving、FlexibleInstances
构建取决于：基础>=4.6&&=0.13.0.2，变压器>=0.4.2.0，mtl>=2.2.1
--hs源目录：
默认语言：Haskell 2010

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

{-#语言包导入}
模块主要在哪里
进口管制
导入“gtk3”Graphics.UI.Gtk
导入“gtk3”Graphics.UI.Gtk.Buttons.Button
导入“gtk3”Graphics.UI.Gtk.General.Enums
导入控制.Monad.IO.Class（liftIO）
导入WidgetBehavior
main=do
initGUI
builder您的问题是由于您在聆听视口上的运动事件的同时不断拉动视口造成的

我找到的简单解决方案是将
滚动窗口
包装在
GtkEventBox
中（我在代码中调用了
eventbox
），然后将事件侦听器附加到该窗口。这样，您正在收听的小部件不会四处移动（它是固定的
GtkEventBox
）

我用这种方法进行的平移非常平滑

-- 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

{-# 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

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

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