1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
module GraphicsPicture
( module GraphicsTypes
, module GraphicsText
, module GraphicsRegion
, module GraphicsFont
, module GraphicsBrush
, module GraphicsPen
, module GraphicsBitmap
, empty, over, overMany
, ellipse, shearEllipse, line
, polyline, polygon, polyBezier
, withRGB
, DrawFun, drawPicture, drawBufferedPicture, drawBufferedPictureBC
, drawBufferedPicture', applyDefaults
, savePicture
) where
import GraphicsTypes
import GraphicsText
import GraphicsRegion
import GraphicsFont
import GraphicsBrush
import GraphicsPen
import GraphicsBitmap
import qualified Win32
import GraphicsUtilities( bracket, bracket_ )
----------------------------------------------------------------
empty :: Picture
over :: Picture -> Picture -> Picture
overMany :: [Picture] -> Picture
ellipse :: Point -> Point -> Picture
shearEllipse :: Point -> Point -> Point -> Picture
line :: Point -> Point -> Picture
polyline :: [Point] -> Picture
polygon :: [Point] -> Picture
polyBezier :: [Point] -> Picture
-- select a color for printing text, drawing lines, and filling areas
withRGB :: RGB -> Picture -> Picture
----------------------------------------------------------------
empty = \ hdc -> return ()
p `over` q = \ hdc -> q hdc >> p hdc
overMany = foldr over empty
ellipse p0 p1 = \ hdc -> Win32.ellipse hdc x0 y0 x1 y1
where
(x0,y0) = fromPoint p0
(x1,y1) = fromPoint p1
shearEllipse p0 p1 p2 = \ hdc ->
Win32.transformedEllipse hdc (fromPoint p0) (fromPoint p1) (fromPoint p2)
line p0 p1 = \ hdc -> Win32.moveToEx hdc x0 y0 >> Win32.lineTo hdc x1 y1
where
(x0,y0) = fromPoint p0
(x1,y1) = fromPoint p1
polyline pts = \ hdc -> Win32.polyline hdc (map fromPoint pts)
polygon pts = \ hdc -> Win32.polygon hdc (map fromPoint pts)
polyBezier pts = \ hdc -> Win32.polyBezier hdc (map fromPoint pts)
withRGB c p =
mkBrush c $ \ brush ->
withBrush brush $
mkPen Solid 2 c $ \ pen ->
withPen pen $
withTextColor c $
p
----------------------------------------------------------------
-- These don't really seem to belong here
type DrawFun = Win32.HWND -> Win32.HDC -> IO ()
drawPicture :: Picture -> DrawFun
drawBufferedPicture :: Picture -> DrawFun
drawBufferedPictureBC :: Win32.RasterOp3 -> RGB -> Picture -> DrawFun
savePicture :: String -> Point -> Picture -> IO ()
drawBufferedPicture' :: Picture -> Win32.HWND -> IO ()
----------------------------------------------------------------
backgroundColor = Win32.bLACKNESS
--backgroundColor = Win32.wHITENESS
defaultColor = RGB 255 255 255
applyDefaults :: Picture -> Picture
applyDefaults p =
withRGB defaultColor $
withBkMode Transparent $
p
drawPicture p = \ hwnd hdc -> do
(w,h) <- windowSize hwnd
Win32.bitBlt hdc 0 0 w h hdc 0 0 backgroundColor
applyDefaults p hdc
-- Note that we create a bitmap which is compatible with the hdc
-- onto which we are going to zap the picture. It might seem that
-- it would be enough for it to be compatible with the buffer -
-- but, sadly, this isn't the case. The problem is that the buffer
-- is initially 0 pixels wide, 0 pixels high and 1 bit deep
-- (ie it looks monochrome); it only becomes n-bits deep when you
-- select in a bitmap which is n-bits deep.
--
-- If it wasn't for that, we'd have swapped these two lines:
--
-- withCompatibleBitmap w h $ \ bitmap ->
-- withCompatibleDC $ \ hdc ->
--
drawBufferedPicture = drawBufferedPictureBC backgroundColor defaultColor
drawBufferedPictureBC bgColor dColor p = \ hwnd hdc -> do
(w,h) <- windowSize hwnd
withDC (Just hwnd) $
withCompatibleBitmap w h $ \ bitmap ->
withCompatibleDC $ \ _ ->
withBitmap bitmap $ \ buffer -> do
Win32.bitBlt buffer 0 0 w h buffer 0 0 bgColor
applyDefaults (withRGB dColor p) buffer
Win32.bitBlt hdc 0 0 w h buffer 0 0 Win32.sRCCOPY
drawBufferedPicture' p = \ hwnd -> do
(w,h) <- windowSize hwnd
withDC (Just hwnd) $ \ hdc -> (
withCompatibleBitmap w h $ \ bitmap ->
withCompatibleDC $ \ _ ->
withBitmap bitmap $ \ buffer -> do
Win32.bitBlt buffer 0 0 w h buffer 0 0 backgroundColor
applyDefaults p buffer
Win32.bitBlt hdc 0 0 w h buffer 0 0 Win32.sRCCOPY
) hdc
savePicture fileName size p =
let (w,h) = fromPoint size in
withDC Nothing $
withCompatibleBitmap w h $ \ bitmap ->
withCompatibleDC $ \ _ ->
withBitmap bitmap $ \ buffer -> do
Win32.bitBlt buffer 0 0 w h buffer 0 0 backgroundColor
p buffer
createBitmapFile fileName bitmap buffer
where
backgroundColor = Win32.bLACKNESS
withDC :: Maybe Win32.HWND -> (Win32.HDC -> IO ()) -> IO ()
withDC mhwnd =
bracket (Win32.getDC mhwnd) (Win32.releaseDC mhwnd)
-- Get the width and height of a window's client area, in pixels.
windowSize :: Win32.HWND -> IO (Win32.LONG,Win32.LONG)
windowSize hwnd =
Win32.getClientRect hwnd >>= \ (l',t',r',b') ->
return (r' - l', b' - t')
|
