构建Haskell（gtk2hs）GUI的

我试图用Gtk2Hs构建中等大小的GUI，我并不是所有人都知道什么是构建系统的最佳方式。我正在寻找一种独立开发子组件的方式，一般来说，最终的结构不会让我稍后拔出头发。构建Haskell（gtk2hs）GUI的

主要困难是由API等基于延续的摄像头等组件造成的（也就是说，我需要使用带有withVideoMode :: Camera Undefined -> (Camera a -> IO()) -> IO()的摄像头来包裹该块）。我想分开这些，但我还没有找到一个合理的方法来做到这一点。

，我需要补充的大多数组件需要初始化，如设置相机参数或建筑物部件，由其他组件和清理，如断开硬件，在年底触发捕获事件。

到目前为止，我已经考虑过使用ContT作为cps零件，并且在组件中使用了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

来源

2013-03-13 aleator

您的要点链接似乎被打破 – cdk 2013-03-13 14:29:49

嗯。看来，我今天只能制造破碎的要旨。我在这里包含了代码，虽然它很长。 – aleator 2013-03-13 15:11:40

似乎你在'main'中做了很多工作。尝试将资源初始化/终止代码重构为单独的函数，以便您可以利用'Control.Exception'中的'bracket'模式：http://hackage.haskell.org/packages/archive/base/latest/doc/ html/Control-Exception-Base.html＃v：括号 – cdk 2013-03-13 15:23:37