5

我正在尝试使用 Gtk2Hs 构建中型 GUI，但我不太确定构建系统的最佳方式是什么。我正在寻找一种方法来单独开发子组件，并且通常最终得到一个不会让我以后拔头发的结构。

主要困难是由 API 是基于延续的相机等组件引起的（即，我需要使用带有 的相机包装块withVideoMode :: Camera Undefined -> (Camera a -> IO ()) -> IO ()）。我也想将它们分开，但我还没有找到合理的方法来做到这一点。

我需要添加的大多数组件都需要初始化，例如设置相机参数或构建小部件，捕获由其他组件触发的事件以及最后的清理，例如断开硬件。

到目前为止，我已经考虑过使用ContTcps 部件和类似 snaplets 的组件，并将它们隐藏在某个State地方。第一个看起来非常重量级，第二个看起来很讨厌，因为我不能在 gtk2hs 回调中优雅地使用转换器。

（由于某种原因，今天的要点对我不起作用，所以很抱歉在这里发布整个巨大的代码）

{-#LANGUAGE ScopedTypeVariables#-}
{-#LANGUAGE DataKinds #-}

import CV.CVSU
import CV.CVSU.Rectangle
import CV.Image as CV
import CV.Transforms
import CV.ImageOp 
import CV.Drawing as CV
import CVSU.PixelImage
import CVSU.TemporalForest
import Control.Applicative
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Array.MArray
import Data.IORef
import Data.Maybe
import Data.Word
import Utils.Rectangle
import Foreign.Ptr
import Graphics.UI.Gtk

import System.Camera.Firewire.Simple

convertToPixbuf :: CV.Image RGB D8 -> IO Pixbuf
convertToPixbuf cv = withRawImageData cv $ \stride d -> do
    pixbufNewFromData (castPtr d) ColorspaceRgb False 8 w h stride
   where (w,h) = getSize cv


initializeCamera dc e = do 
    putStrLn $ "Initializing camera "++show e
    cam <- cameraFromID dc e
    setOperationMode cam B
    setISOSpeed  cam ISO_800
    setFrameRate cam Rate_30
    setupCamera cam 20 defaultFlags
    return cam

handleFrame tforest image = do
  pimg    <- toPixelImage (rgbToGray8 image)
  uforest <- temporalForestUpdate tforest pimg
  uimg    <- temporalForestVisualize uforest
  --uimage  <- expectByteRGB =<< fromPixelImage uimg
  temporalForestGetSegments uforest

  --mapM (temporalForestGetSegmentBoundary uforest) ss

createThumbnail img = do 
     pb     <- convertToPixbuf $ unsafeImageTo8Bit $ scaleToSize Linear True (95,95) (unsafeImageTo32F img)
     imageNewFromPixbuf pb


main :: IO ()
main = withDC1394 $ \dc -> do
    -- ** CAMERA Setup **
    cids <- getCameras dc
    cams <- mapM (initializeCamera dc) $ cids

    -- ** Initialize GUI ** 
    initGUI
    pp <- pixbufNew ColorspaceRgb False 8 640 480
    window <- windowNew

    -- * Create the image widgets 
    images <- vBoxNew True 3
    image1  <- imageNewFromPixbuf pp
    image2  <- imageNewFromPixbuf pp
    boxPackStart images image1 PackGrow 0 
    boxPackEnd   images image2 PackGrow 0 

    -- * Create the Control & main widgets
    screen     <- hBoxNew True 3
    control    <- vBoxNew True 3
    info       <- labelNew (Just "This is info")
    but        <- buttonNewWithLabel "Add thumbnail"
    thumbnails <- hBoxNew True 2
    boxPackStart screen images PackGrow 0 
    boxPackStart screen control PackGrow 0 
    boxPackStart control info PackGrow 0 
    boxPackStart control but PackRepel 0 
    boxPackStart control thumbnails PackGrow 0 
    but `onClicked` (do
        info<- labelNew (Just "This is info")
        widgetShowNow info
        boxPackStart thumbnails info PackGrow 0)

    set window [ containerBorderWidth := 10
                   , containerChild := screen ]

    -- ** Start video transmission **
    withVideoMode (cams !! 0) $ \(c :: Camera Mode_640x480_RGB8) -> do
--     withVideoMode (cams !! 1) $ \(c2 :: Camera Mode_640x480_RGB8) -> do
        -- ** Start cameras ** --
        startVideoTransmission c
--        startVideoTransmission c2
        -- ** Setup background subtraction ** --
        Just f <- getFrame c 
        pimg <- toPixelImage (rgbToGray8 f)
        tforest <- temporalForestCreate 16 4 10 130 pimg

        -- * Callback for gtk
        let grabFrame = do
            frame <- getFrame c 
--            frame2 <- getFrame c2 
            maybe (return ()) 
                  (\x -> do
                          ss <- handleFrame tforest x
                          let area = sum [ rArea r | r <- (map segToRect ss)]
                          if area > 10000 
                                then return ()
                                 --putStrLn "Acquiring a thumbnail"
                                 --tn <- createThumbnail x
                                 --boxPackStart thumbnails tn PackGrow 0 
                                 --widgetShowNow tn
                                 --containerResizeChildren thumbnails
                                else return ()
                          labelSetText info ("Area: "++show area)
                          pb <- convertToPixbuf
                                    --  =<< CV.drawLines x (1,0,0) 2 (concat segmentBoundary)
                                    (x <## map (rectOp (1,0,0) 2) (map segToRect ss) )
                          pb2 <- convertToPixbuf x
                          imageSetFromPixbuf image1 pb
                          imageSetFromPixbuf image2 pb2
                          )
                  frame
--            maybe (return ()) 
--                  (convertToPixbuf >=> imageSetFromPixbuf image2)
--                  frame2
            flushBuffer c 
--            flushBuffer c2 
            return True

        timeoutAddFull grabFrame priorityDefaultIdle 20

        -- ** Setup finalizers ** 
        window `onDestroy` do
                    stopVideoTransmission c
                    stopCapture c
                    mainQuit

        -- ** Start GUI **
        widgetShowAll window
        mainGUI
4

1 回答 1

3

所以你的要求是：

  • CPS 风格 API
  • 资源初始化和终结
  • 可能是一个单子变压器，用于 IO
  • 模块化和可组合性

似乎其中一个迭代器库非常适合您。特别是conduit具有最成熟的资源最终确定性，但pipes您可能也会对它的理论优雅和可组合性感兴趣。如果你的代码只是IO基于，那么新发布的io-streams也将是一个不错的选择。

pipes：http ://hackage.haskell.org/packages/archive/pipes/3.1.0/doc/html/Control-Proxy-Tutorial.html

conduit：https ://www.fpcomplete.com/school/pick-of-the-week/conduit-overview

io-streams：http ://hackage.haskell.org/packages/archive/io-streams/1.0.1.0/doc/html/System-IO-Streams-Tutorial.html

如果您提供一个小片段或描述您要完成的工作，我可以尝试使用pipes（我最熟悉的库）编写它

于 2013-03-13T14:27:52.767 回答