Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Added a new paintContext event handler which includes a GraphicsConte…

…xt argument.
  • Loading branch information...
commit a779f8e7e34fe03822f380c4cdd1aa8a9ed97e81 1 parent 2f065e5
Kristof Bastiaensen authored
View
10 wx/src/Graphics/UI/WX/Events.hs
@@ -72,6 +72,7 @@ module Graphics.UI.WX.Events
, closing, idle, resize, focus, activate
, Paint
, paint, paintRaw, repaint
+ , paintContext, paintRawContext
-- * Event filters
-- ** Mouse filters
, enter, leave, motion, drag
@@ -166,6 +167,15 @@ class Paint w where
-- | Paint directly to the on-screen device context. Takes the current
-- view rectangle and a list of dirty rectangles as arguments.\
paintRaw :: Event w (DC () -> Rect -> [Rect] -> IO ())
+ -- | Paint double buffered to a device context, using a
+ -- graphicsContext. The context is always cleared before
+ -- drawing. Takes the current view rectangle (adjusted for
+ -- scrolling) as an argument.
+ paintContext :: Event w (DC () -> GraphicsContext () -> Rect -> IO ())
+ -- | Paint directly to the on-screen device context, using a
+ -- graphicsContext. Takes the current view rectangle and a list of
+ -- dirty rectangles as arguments.\
+ paintRawContext :: Event w (DC () -> GraphicsContext () -> Rect -> [Rect] -> IO ())
-- | Emit a paint event to the specified widget.
repaint :: w -> IO ()
View
2  wx/src/Graphics/UI/WX/Window.hs
@@ -436,4 +436,6 @@ instance Reactive (Window a) where
instance Paint (Window a) where
paint = newEvent "paint" windowGetOnPaint (\w h -> windowOnPaint w h)
paintRaw = newEvent "paintRaw" windowGetOnPaintRaw (\w h -> windowOnPaintRaw w h)
+ paintContext = newEvent "paint" windowGetOnPaintContext (\w h -> windowOnPaintContext w h)
+ paintRawContext = newEvent "paintRaw" windowGetOnPaintRawContext (\w h -> windowOnPaintRawContext w h)
repaint w = windowRefresh w False
View
2  wxc/Setup.hs
@@ -233,7 +233,7 @@ bitnessMismatch =
readWxConfig :: IO String
readWxConfig = do
-- Try to force version and see if we have it
- let wxRequiredVersion = "2.9"
+ let wxRequiredVersion = "3.0"
-- The Windows port of wx-config doesn't let you specify a version, nor query the full version,
-- accordingly we just check what version is installed (which is returned with --release)
View
9 wxc/src/cpp/graphicscontext.cpp
@@ -43,6 +43,15 @@ EWXWEXPORT(wxGraphicsContext*,wxGraphicsContext_Create)( const wxWindowDC* dc )
#endif
}
+EWXWEXPORT(wxGraphicsContext*,wxGraphicsContext_CreateFromMemory)( const wxMemoryDC* dc )
+{
+#ifdef wxUSE_GRAPHICS_CONTEXT
+ return wxGraphicsContext::Create(*dc);
+#else
+ return NULL;
+#endif
+}
+
EWXWEXPORT(wxGraphicsContext*,wxGraphicsContext_CreateFromWindow)( wxWindow* window )
{
#ifdef wxUSE_GRAPHICS_CONTEXT
View
1  wxc/src/include/graphicscontext.h
@@ -17,6 +17,7 @@ void wxGraphicsBrush_Delete(TSelf(wxGraphicsBrush) self);
GraphicsContext
-----------------------------------------------------------------------------*/
TClass(wxGraphicsContext) wxGraphicsContext_Create( TClass(wxWindowDC) dc );
+TClass(wxGraphicsContext) wxGraphicsContext_CreateFromMemory( TClass(wxMemoryDC) dc );
TClass(wxGraphicsContext) wxGraphicsContext_CreateFromWindow( TClass(wxWindow) window );
void wxGraphicsContext_Delete(TSelf(wxGraphicsContext) self);
TClass(wxGraphicsContext) wxGraphicsContext_CreateFromNative( void* context );
View
81 wxcore/src/haskell/Graphics/UI/WXCore/Draw.hs
@@ -21,6 +21,7 @@ module Graphics.UI.WXCore.Draw
, DrawState, dcEncapsulate, dcGetDrawState, dcSetDrawState, drawStateDelete
-- ** Double buffering
, dcBuffer, dcBufferWithRef, dcBufferWithRefEx
+ , dcBufferWithRefExContext
-- * Scrolled windows
, windowGetViewStart, windowGetViewRect, windowCalcUnscrolledPosition
-- * Font
@@ -845,3 +846,83 @@ dcBufferWithRefEx dc clear mbVar view draw
-- blit the memdc into the owner dc.
dcBlit dc view memdc (rectTopLeft view) wxCOPY False
return ()
+
+-- | Optimized double buffering with graphicsContext. Takes a /clear/
+-- routine as its first argument. Normally this is something like
+-- '\dc -> dcClearRect dc viewArea' but on certain platforms, like
+-- MacOS X, special handling is necessary.
+dcBufferWithRefExContext :: WindowDC a -> (DC () -> IO ()) -> Maybe (Var (Bitmap ())) -> Rect -> (DC () -> GraphicsContext () -> IO ()) -> IO ()
+dcBufferWithRefExContext dc clear mbVar view draw
+ | rectSize view == sizeZero = return ()
+dcBufferWithRefExContext dc clear mbVar view draw
+ = bracket (initBitmap)
+ (doneBitmap)
+ (\bitmap ->
+ if (bitmap==objectNull)
+ then drawUnbuffered
+ else bracket (do p <- memoryDCCreateCompatible dc; return (objectCast p))
+ (\memdc -> when (memdc/=objectNull) (memoryDCDelete memdc))
+ (\memdc -> if (memdc==objectNull)
+ then drawUnbuffered
+ else do memoryDCSelectObject memdc bitmap
+ drawBuffered memdc
+ memoryDCSelectObject memdc nullBitmap
+ )
+ )
+ where
+ initBitmap
+ = case mbVar of
+ Nothing -> bitmapCreateEmpty (rectSize view) (-1)
+ Just v -> do bitmap <- varGet v
+ size <- if (bitmap==objectNull)
+ then return sizeZero
+ else do bw <- bitmapGetWidth bitmap
+ bh <- bitmapGetHeight bitmap
+ return (Size bw bh)
+ -- re-use the bitmap if possible
+ if (sizeEncloses size (rectSize view) && bitmap /= objectNull)
+ then return bitmap
+ else do when (bitmap/=objectNull) (bitmapDelete bitmap)
+ varSet v objectNull
+ -- new size a bit larger to avoid multiple reallocs
+ let (Size w h) = rectSize view
+ neww = div (w*105) 100
+ newh = div (h*105) 100
+ bm <- bitmapCreateEmpty (sz neww newh) (-1)
+ varSet v bm
+ return bm
+
+ doneBitmap bitmap
+ = case mbVar of
+ Nothing -> when (bitmap/=objectNull) (bitmapDelete bitmap)
+ Just v -> return ()
+
+
+ drawUnbuffered
+ = do clear (downcastDC dc)
+ gc <- graphicsContextCreate dc
+ draw (downcastDC dc) gc
+ graphicsContextDelete gc
+
+ drawBuffered memdc
+ = do -- set the device origin for scrolled windows
+ dcSetDeviceOrigin memdc (pointFromVec (vecNegate (vecFromPoint (rectTopLeft view))))
+ dcSetClippingRegion memdc view
+ -- dcBlit memdc view dc (rectTopLeft view) wxCOPY False
+ bracket (dcGetBackground dc)
+ (\brush -> do dcSetBrush memdc nullBrush
+ brushDelete brush)
+ (\brush -> do -- set the background to the owner brush
+ dcSetBackground memdc brush
+ if (wxToolkit == WxMac)
+ then withBrushStyle brushTransparent (dcSetBrush memdc)
+ else dcSetBrush memdc brush
+ clear (downcastDC memdc)
+ -- and finally do the drawing!
+ gc <- graphicsContextCreateFromMemory memdc
+ draw (downcastDC memdc) gc
+ graphicsContextDelete gc
+ )
+ -- blit the memdc into the owner dc.
+ dcBlit dc view memdc (rectTopLeft view) wxCOPY False
+ return ()
View
73 wxcore/src/haskell/Graphics/UI/WXCore/Events.hs
@@ -54,6 +54,8 @@ module Graphics.UI.WXCore.Events
, windowOnActivate
, windowOnPaint
, windowOnPaintRaw
+ , windowOnPaintContext
+ , windowOnPaintRawContext
, windowOnContextMenu
, windowOnScroll
, htmlWindowOnHtmlEvent
@@ -110,6 +112,8 @@ module Graphics.UI.WXCore.Events
, windowGetOnActivate
, windowGetOnPaint
, windowGetOnPaintRaw
+ , windowGetOnPaintContext
+ , windowGetOnPaintRawContext
, windowGetOnContextMenu
, windowGetOnScroll
, htmlWindowGetOnHtmlEvent
@@ -1030,12 +1034,48 @@ windowOnPaintRaw window paintHandler
when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC)
paintHandler (downcastDC paintDC) view region)
+-- | Set an event handler for /raw/ paint events, and also pass a
+-- graphicsContext. Draws directly to the paint device context
+-- ('PaintDC') and the 'DC' is not cleared when the handler is
+-- called. The handler takes two other arguments: the view rectangle
+-- and a list of /dirty/ rectangles. The rectangles contain logical
+-- coordinates and are already adjusted for scrolled windows. Note:
+-- you can not set both a 'windowOnPaintRaw' and 'windowOnPaint'
+-- handler!
+windowOnPaintRawContext :: Window a -> (DC () -> GraphicsContext () -> Rect -> [Rect] -> IO ()) -> IO ()
+windowOnPaintRawContext window paintHandler
+ = windowOnEvent window [wxEVT_PAINT] paintHandler onPaint
+ where
+ onPaint event
+ = do obj <- eventGetEventObject event
+ if (obj==objectNull)
+ then return ()
+ else do let window = objectCast obj
+ region <- windowGetUpdateRects window
+ view <- windowGetViewRect window
+ withPaintDC window (\paintDC ->
+ do isScrolled <- objectIsScrolledWindow window
+ when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC)
+ gc <- graphicsContextCreate paintDC
+ paintHandler (downcastDC paintDC) gc view region
+ graphicsContextDelete gc)
+
-- | Get the current /raw/ paint event handler.
windowGetOnPaintRaw :: Window a -> IO (DC () -> Rect -> [Rect] -> IO ())
windowGetOnPaintRaw window
= unsafeWindowGetHandlerState window wxEVT_PAINT (\dc rect region -> return ())
+-- | Get the current /raw/ graphicsContext paint event handler.
+windowGetOnPaintRawContext :: Window a -> IO (DC () -> GraphicsContext () -> Rect -> [Rect] -> IO ())
+windowGetOnPaintRawContext window
+ = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc gc rect region -> return ())
+
+-- | Get the current graphicsContext paint event handler.
+windowGetOnPaintContext :: Window a -> IO (DC () -> GraphicsContext () -> Rect -> IO ())
+windowGetOnPaintContext window
+ = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc gc view -> return ())
+
-- | Set an event handler for paint events. The implementation uses an
-- intermediate buffer for non-flickering redraws.
@@ -1068,6 +1108,39 @@ windowOnPaint window paintHandler
| otherwise = dcClear dc
-- and repaint with buffer
dcBufferWithRefEx paintDC clear (Just v) view (\dc -> paintHandler dc view))
+-- | Set an event handler for paint events, and also pass a
+-- graphicsContext. The implementation uses an intermediate buffer for
+-- non-flickering redraws. The device context ('DC') is always
+-- cleared before the paint handler is called. The paint handler also
+-- gets the currently visible view area as an argument (adjusted for
+-- scrolling). Note: you can not set both a 'windowOnPaintRaw' and
+-- 'windowOnPaint' handler!
+windowOnPaintContext :: Window a -> (DC () -> GraphicsContext () -> Rect -> IO ()) -> IO ()
+windowOnPaintContext window paintHandler
+ | wxToolkit == WxMac = windowOnPaintRawContext window (\dc gc view _ -> paintHandler dc gc view)
+ | otherwise
+ = do v <- varCreate objectNull
+ windowOnEventEx window [wxEVT_PAINT] paintHandler (destroy v) (onPaint v)
+ where
+ destroy v ownerDeleted
+ = do bitmap <- varSwap v objectNull
+ when (not (objectIsNull bitmap)) (bitmapDelete bitmap)
+
+ onPaint v event
+ = do obj <- eventGetEventObject event
+ if (obj==objectNull)
+ then return ()
+ else do let window = objectCast obj
+ view <- windowGetViewRect window
+ withPaintDC window (\paintDC ->
+ do isScrolled <- objectIsScrolledWindow window
+ when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC)
+ -- Note: wxMSW 2.4 does not clear the properly scrolled view rectangle.
+ let clear dc | wxToolkit == WxMSW = dcClearRect dc view
+ | otherwise = dcClear dc
+ -- and repaint with buffer
+ dcBufferWithRefExContext paintDC clear (Just v) view (\dc gc -> paintHandler dc gc view))
+
-- | Get the current paint event handler.
Please sign in to comment.
Something went wrong with that request. Please try again.