私はGtk2Hsで中規模のGUIを構築しようとしていますが、私はシステムを構成する最善の方法は何もわかりません。私は、孤立してサブコンポーネントを開発する方法を探していて、一般的には後で私の髪を引き抜かない構造になってしまいます。構造化Haskell(gtk2hs)GUIの
主な問題は、APIが継続しているカメラなどのコンポーネント(つまり、withVideoMode :: Camera Undefined -> (Camera a -> IO()) -> IO()
のカメラを使用してブロックをラップする必要がある)が原因です。私もこれらを分けたいですが、私はこれを行う合理的な方法を見つけていません。私は追加する必要が
ほとんどのコンポーネントは、このようなカメラパラメータや建物のウィジェットは、そのような最後に、ハードウェアを取り外すなどの他のコンポーネントとクリーンアップ、によってトリガーされる引くイベントを設定するなど、初期が必要です。
これまでのところ、私はContT
をcpsの部分に使用し、コンポーネントのスナップショットのようなものをどこかの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
あなたのリンクは壊れているようです – cdk
うーん。今日は壊れた要点しか作ることができないようです。私はここにコードを含めましたが、かなり長いです。 – aleator
あなたは 'main'で多くの仕事をしているようです。リソースの初期化/終了コードを別々の関数にリファクタリングして、 'Control.Exception'の' bracket'パターンを利用できるようにしてください:http://hackage.haskell.org/packages/archive/base/latest/doc/ html/Control-Exception-Base.html#v:ブラケット – cdk