Bonjour List,
A few weeks ago I needed help to find out how to scale an image.
Once I managed to make it work, I was suggested to modify the example
to show how it can be done.
So here's a quickly modified ImageViewer.hs. It's not a big change !
I'd like someone to review the changes before I send a patch, please.
Thanks,
David.
{-----------------------------------------------------------------------------------------
Copyright (c) Daan Leijen 2003
wxWindows License.
An image viewer in wxHaskell.
Demonstrates:
- menus, toolbars and the statusbar
- standard file dialogs
- scrollable windows
- drawing on DC's (device contexts)
- image handling
-----------------------------------------------------------------------------------------}
module Main where
import Prelude hiding(catch)
import Control.Exception(catch,SomeException)
import Graphics.UI.WX
import Graphics.UI.WXCore
main :: IO ()
main
= start imageViewer
-- Specify image files for the file open dialog.
imageFiles :: [(String, [String])]
imageFiles
= [("Image files",["*.bmp","*.jpg","*.gif","*.png"])
,("Portable Network Graphics (*.png)",["*.png"])
,("BMP files (*.bmp)",["*.bmp"])
,("JPG files (*.jpg)",["*.jpg"])
,("GIF files (*.gif)",["*.gif"])
]
-- Display modes (zoom)
data Zoom = Original | Fit
changeZoom :: Zoom -> Zoom
changeZoom Original = Fit
changeZoom Fit = Original
-- The image viewer.
imageViewer :: IO ()
imageViewer
= do -- the main frame, we use 'fullRepaintOnResize' to prevent flicker on resize
f <- frame [text := "ImageViewer", picture := "../bitmaps/eye.ico", fullRepaintOnResize := False]
-- use a mutable variable to hold the image
vbitmap <- variable [value := Nothing]
-- another mutable variable for the zoom level.
vzoom <- variable [ value := Fit ]
-- add a scrollable window widget in the frame
sw <- scrolledWindow f [scrollRate := sz 10 10, bgcolor := white
,fullRepaintOnResize := False]
set sw [on paint := onPaint vbitmap vzoom sw ]
-- create file menu
file <- menuPane [text := "&File"]
mclose <- menuItem file [text := "&Close\tCtrl+C", help := "Close the image", enabled := False]
open <- menuItem file [text := "&Open\tCtrl+O", help := "Open an image"]
menuLine file
quit <- menuQuit file [help := "Quit the demo"]
-- create Help menu
hlp <- menuHelp []
about <- menuAbout hlp [help := "About ImageViewer"]
-- create Toolbar
tbar <- toolBar f []
toolMenu tbar open "Open" "../bitmaps/fileopen16.png" []
toolMenu tbar about "About" "../bitmaps/wxwin16.png" []
toolItem tbar "Zoom" True "../bitmaps/wxwin16.png" [ on command := onZoom vbitmap vzoom sw ]
-- create statusbar field
status <- statusField [text := "Welcome to the wxHaskell ImageViewer"]
-- set the statusbar, menubar, layout, and add menu item event handlers
-- note: set the layout before the menubar!
set f [layout := column 1 [hfill $ hrule 1 -- add divider between toolbar and scrolledWindow
,fill (widget sw)]
,statusBar := [status]
,menuBar := [file,hlp]
,outerSize := sz 400 300 -- niceness
,on (menu about) := infoDialog f "About ImageViewer" "This is a wxHaskell demo"
,on (menu quit) := close f
,on (menu open) := onOpen f sw vbitmap vzoom mclose status
,on (menu mclose) := onClose sw vbitmap mclose status
-- nice close down, but no longer necessary as bitmaps are managed automatically.
,on closing :~ \previous -> do{ closeImage vbitmap; previous }
]
where
onOpen :: Frame a -> ScrolledWindow b -> Var (Maybe (Bitmap ())) -> Var Zoom -> MenuItem c -> StatusField -> IO ()
onOpen f sw vbitmap vzoom mclose status
= do mbfname <- fileOpenDialog f False {- change current directory -} True "Open image" imageFiles "" ""
case mbfname of
Nothing -> return ()
Just fname -> openImage sw vbitmap vzoom mclose status fname
onClose sw vbitmap mclose status
= do closeImage vbitmap
set mclose [enabled := False]
set sw [virtualSize := sz 0 0]
set status [text := ""]
repaint sw
closeImage vbitmap
= do mbBitmap <- swap vbitmap value Nothing
case mbBitmap of
Nothing -> return ()
Just bm -> objectDelete bm
openImage sw vbitmap vzoom mclose status fname
= do -- load the new bitmap
bm <- bitmapCreateFromFile fname -- can fail with exception
closeImage vbitmap
set vbitmap [value := Just bm]
set mclose [enabled := True]
set status [text := fname]
setVirtualSize vzoom bm sw
`catch` (( \_err -> repaint sw) :: SomeException -> IO ())
onZoom vbitmap vzoom sw
= do set vzoom [ value :~ changeZoom ]
mbBitmap <- get vbitmap value
case mbBitmap of
Nothing -> return ()
Just bm -> setVirtualSize vzoom bm sw
onPaint vbitmap vzoom sw dc _viewArea
= do mbBitmap <- get vbitmap value
case mbBitmap of
Nothing -> return ()
Just bm -> do
zoom <- get vzoom value
onPaint' bm zoom sw dc
onPaint' bm Original _ dc
= drawBitmap dc bm pointZero False []
onPaint' bm Fit sw dc
= do
bsize <- get bm size
vsize <- get sw size
let (ofs,scale) = calcScaleAndPos bsize vsize
dcSetUserScale dc scale scale
drawBitmap dc bm ofs False []
--
setVirtualSize vzoom bm sw
= do zoom <- get vzoom value
case zoom of
Original -> do
-- reset the scrollbars
bmsize <- get bm size
set sw [virtualSize := bmsize]
Fit -> do
csize <- get sw clientSize
set sw [ virtualSize := csize ]
repaint sw
-- we can have a margin of white pixels when trying to fit the image.
sizeMargin :: Int
sizeMargin = 3
-- compute the coordinates and scale.
calcScaleAndPos :: Size -> Size -> (Point,Double)
calcScaleAndPos (Size bw bh) (Size vw vh) = (ofs,scale)
where scalew = fromIntegral vw' / fromIntegral bw
scaleh = fromIntegral vh' / fromIntegral bh
vw' = vw - sizeMargin * 2
vh' = vh - sizeMargin * 2
scale = min scalew scaleh
svw = round( fromIntegral vw / scale )
svh = round( fromIntegral vh / scale )
ofs = pt ((svw-bw) `div` 2) ((svh-bh) `div` 2)
------------------------------------------------------------------------------
BlackBerry® DevCon Americas, Oct. 18-20, San Francisco, CA
http://p.sf.net/sfu/rim-devcon-copy2
_______________________________________________
wxhaskell-devel mailing list
wxhaskell-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/wxhaskell-devel
