wxHaskell   ImageViewer

ホーム   目次

この章では、ImageViewerを作っています。

ImageViewer

スクロールドウィンドウもつけました。

imageViewer.hs

module Main where

import Control.Exception( onException )
import Graphics.UI.WXCore   -- include run
import Graphics.UI.WX       -- include start

main :: IO ()
main = start gui

gui :: IO ()
gui = do 
    -- 現在のビットマップを保持する変数
    vbitmap <- varCreate Nothing
    
    f       <-  frame       [text := "ImageViewer"]
    sw       <-  scrolledWindow
                          f [scrollRate :=sz 10 10
                            ,on paint := onPaint vbitmap
                            ,fullRepaintOnResize := False
                            ]
    m       <-  menuPane    [text := "File"]
    about   <-  menuAbout m [on command := infoDialog f
                            "ImageViewer"
                            "Version 0.9\n© appdesing.jp"]
    open    <- menuItem   m [text := "Open\tCtrl+O"
                            ,on command := onOpen f vbitmap sw]
    clear   <- menuItem   m [text := "Clear\tCtrl+C"
                            ,on command := onClear f vbitmap sw]
    _       <- menuLine   m
    quit    <- menuQuit   m [on command := onQuit f]
    
    set f   [layout := fill (widget sw)
            ,menuBar := [m]
            ,clientSize := sz 480 270]
     return ()
  where
    onQuit f = do
        _   <-  windowClose f True
        return ()
    onOpen f vbitmap sw = do
        file <- fileOpenDialog f False True "Open image" imageFiles "" ""
        case file of
            Nothing
                -> return ()
            Just path -> do
                bm <- bitmapCreateFromFile path  -- 例外で失敗する可能性があります
                bmsize <- bitmapGetSize bm
                set sw [virtualSize := bmsize]
                 withClientDC sw dcClear
                varSet vbitmap (Just bm)
                view <- windowGetViewRect sw
                withClientDC sw (\dc -> onPaint vbitmap dc view)
                refresh f
             `onException` return ()
      where
        imageFiles
           = [("Image files",["*.bmp","*.jpg","*.gif","*.png","*.ico"])
             ,("Portable Network Graphics (*.png)",["*.png"])
             ,("BMP files (*.bmp)",["*.bmp"])
             ,("JPG files (*.jpg)",["*.jpg"])
             ,("GIF files (*.gif)",["*.gif"])
             ]

    onClear f vbitmap sw = do
        close f vbitmap
        -- 古いビットマップを明示的に削除する
        withClientDC sw dcClear
        set sw [virtualSize := sz 0 0]
        
    close _f vbitmap = do
        mbBitmap <- varSwap vbitmap Nothing
        case mbBitmap of
            Nothing -> return ()
            Just bm -> bitmapDelete bm

    onPaint vbitmap dc view = do
        mbBitmap <- varGet vbitmap
        case mbBitmap of
            Nothing -> return ()
            Just bm -> do
                let visize   =   rectSize view
                bmsize      <-  bitmapGetSize bm
                dcDrawBitmap dc bm (pt (getX visize bmsize) (getY visize bmsize))
                    False   -- マスクを使いますか？
                return ()
                where
                    getX vi bm
                        | (sizeW vi) < (sizeW bm) = 0
                        | otherwise = ((sizeW vi) - (sizeW bm)) `div` 2
                    getY vi bm
                        | (sizeH vi) < (sizeH bm) = 0
                        | otherwise = ((sizeH vi) - (sizeH bm)) `div` 2

win

mac

lin

ホーム   目次   ページトップ