Draw.hs

{-# LANGUAGE Unsafe, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ImplicitParams, ForeignFunctionInterface #-}

-- | A Draw monad for drawing in bitmaps.
module FRP.Reactivity.Draw (defBackground, Draw(unDraw), pack, onNewBitmap, unsafeOnBitmap, newBitmap, onBitmap, askDims, getPixel, setPixel, askDims', getPixel', getRValue, getGValue, getBValue, rgb, blend, mask, Font, defFont, textOut, textDimensions, areaFill, useFilter, convolve, flipped, swap, correlate, blur, enTuple, unTuple, resample, horzGradient, vertGradient, laplacian, fillRect, function, function', drawBitmap, graffito, spline, ellipse) where

import Foreign.Ptr
import Foreign.Storable
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Data.ByteString (copy, index, replicate)
import qualified Data.ByteString as B
import Data.ByteString.Unsafe
import Data.Bits
import Data.Int
import Data.Word
import Data.Fixed
import Data.Array hiding (index)
import Control.Arrow
import Control.Monad.Reader
import Control.Monad.Trans
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.CUtils.Conc
import Control.Concurrent
import Codec.BMP
import System.IO.Unsafe
import System.Mem.Weak
import Graphics.Win32 hiding (ellipse, fillRect, textOut)
import Graphics.Win32Extras
import Prelude hiding (replicate)

defBackground = rgb 245 246 247

newtype Draw t = Draw { unDraw :: ReaderT ((Int32, Int32), Ptr CChar, Maybe (Chan (Int32, Int32, COLORREF))) IO t } deriving (Functor, Applicative, Monad)

bi bmp = case bmpBitmapInfo bmp of
	InfoV3 b -> b
	InfoV4 b -> dib4InfoV3 b

sizeOfFileHeader :: Int
sizeOfFileHeader = 14

-- | Magic number that should come at the start of a BMP file.
bmpMagic :: Word16
bmpMagic = 0x4d42

-- | Size of `BitmapInfoV3` header (in bytes)
sizeOfBitmapInfoV3 :: Int
sizeOfBitmapInfoV3 = 40

-- 
-- | Pack a 24-bit bitmap, but without error checking.
pack width height str = let
	fileHeader
		= FileHeader
		{ fileHeaderType	= bmpMagic

		, fileHeaderFileSize	= fromIntegral
					$ sizeOfFileHeader + sizeOfBitmapInfoV3	+ B.length str

		, fileHeaderReserved1	= 0
		, fileHeaderReserved2	= 0
		, fileHeaderOffset	= fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) }

	bitmapInfoV3
		= BitmapInfoV3
		{ dib3Size		= fromIntegral sizeOfBitmapInfoV3
		, dib3Width		= fromIntegral width
		, dib3Height		= fromIntegral height
		, dib3HeightFlipped	= False
		, dib3Planes		= 1
		, dib3BitCount		= 24
		, dib3Compression	= CompressionRGB
		, dib3ImageSize		= fromIntegral $ (3 * width + 3) `quot` 4 * 4 * height
		, dib3PelsPerMeterX	= 2834
		, dib3PelsPerMeterY	= 2834

		, dib3ColorsUsed	= 0
		, dib3ColorsImportant	= 0 }
		
   in BMP 
		{ bmpFileHeader		= fileHeader
		, bmpBitmapInfo		= InfoV3 bitmapInfoV3
		, bmpRawImageData	= str }

-- | Create a new bitmap and draw on it.
{-# NOINLINE onNewBitmap #-}
onNewBitmap :: (Int32, Int32) -> Draw t -> (BMP, t)
onNewBitmap (wd32, ht32) draw = unsafePerformIO $ do
	let sz = fromIntegral $ nBytes wd32 ht32
	p <- mallocBytes sz
	let Draw st = fillRect defBackground (0, 0, wd32, ht32) >> draw
	x <- runReaderT st ((wd32, ht32), p, Nothing)
	ar <- unsafePackCStringLen (p, sz)
	addFinalizer ar (free p)
	return (pack wd ht ar, x) where
	wd = fromIntegral wd32
	ht = fromIntegral ht32

-- | Create a new blank bitmap.
{-# INLINE newBitmap #-}
newBitmap dim = fst $ onNewBitmap dim (return ())

-- | Make a copy of a bitmap and draw on it. This only works with 24-bit bitmaps
--   (but the Codec.BMP library provides conversion functions)
{-# NOINLINE onBitmap #-}
onBitmap bmp draw = unsafeOnBitmap (bmp { bmpRawImageData = copy $ bmpRawImageData bmp }) draw

-- | An unsafe version of 'onBitmap' that scribbles on the old bitmap, violating
--   referential transparency.
{-# NOINLINE unsafeOnBitmap #-}
unsafeOnBitmap :: BMP -> Draw t -> (BMP, t)
unsafeOnBitmap bmp draw = unsafePerformIO $ unsafeUseAsCString (bmpRawImageData bmp) $ \p -> do
	let Draw st = draw
	x <- runReaderT st ((wd32, ht32), p, Nothing)
	return (pack wd ht (bmpRawImageData bmp), x) where
	(wd32, ht32) = askDims' bmp
	wd = fromIntegral wd32
	ht = fromIntegral ht32

calculateByte wid x y = (3 * wid + 3) `quot` 4 * 4 * y + 3 * x

nBytes wd32 ht32 = calculateByte wd32 0 ht32

-- | Retrieve the bitmap's dimensions.
askDims = Draw $ liftM (\(pr, _, _) -> pr) ask

{-# INLINE unsafeGetPixel #-}
unsafeGetPixel (x, y) = Draw $ do
	((wid, _), ar, _) <- ask
	let byte = calculateByte wid x y
	lift $ do
		b <- peekByteOff ar (fromIntegral byte)
		g <- peekByteOff ar (fromIntegral $ byte + 1)
		r <- peekByteOff ar (fromIntegral $ byte + 2)
		return (rgb r g b)

-- |
getPixel (x, y) = do
	b <- inBounds (x, y)
	unless b $ do
		(wid, ht) <- askDims
		Draw $ lift $ throwIO $ IndexOutOfBounds $ "FRP.Draw.getPixel: " ++ show (x, y) ++ " not in " ++ show wid ++ "x" ++ show ht ++ " bitmap"
	unsafeGetPixel (x, y)

makeLPARAM x y = shiftL y 16 .|. x

{-# INLINE unsafeSetPixel #-}
unsafeSetPixel (x, y) clr = Draw $ do
	((wid, _), ar, chn) <- ask
	let byte = calculateByte wid x y
	lift $ maybe
		(do
		pokeByteOff ar (fromIntegral byte) (getBValue clr)
		pokeByteOff ar (fromIntegral $ byte + 1) (getGValue clr)
		pokeByteOff ar (fromIntegral $ byte + 2) (getRValue clr))
		(\chn -> writeChan chn (x, y, clr))
		chn

-- |
setPixel pt clr = do
	b <- inBounds pt
	when b $ unsafeSetPixel pt clr

-- |
askDims' :: BMP -> (Int32, Int32)
askDims' bmp = (fromIntegral (dib3Width (bi bmp)), fromIntegral (dib3Height (bi bmp)))

-- |
getPixel' (x, y) bmp = rgb
	(index dat (byte + 2))
	(index dat (byte + 1))
	(index dat byte) where
	dat = bmpRawImageData bmp
	wid = fst (askDims' bmp)
	byte = fromIntegral $ calculateByte wid x y

-- | Blend a colour into a pixel with a certain intensity.
blend :: Double -> (Int32, Int32) -> COLORREF -> Draw ()
blend intensity pt clr = do
	b <- inBounds pt
	when b $ do
		clr2 <- unsafeGetPixel pt
		let formula f = round $ fromIntegral (f clr) * intensity + fromIntegral (f clr2) * (1 - intensity)
		unsafeSetPixel pt $ rgb
			(formula getRValue)
			(formula getGValue)
			(formula getBValue)

-- | Fill a region according to the given mask bitmap.
mask intensity (x, y) bmp = do
	let (wid, ht) = askDims' bmp
	let f = if intensity >= 1 then
			\x2 y2 -> setPixel (x + x2, y + y2)
		else
			\x2 y2 -> blend intensity (x + x2, y + y2)
	mapM_ (\y2 -> mapM_ (\x2 -> f x2 y2 (getPixel' (x2, y2) bmp)) [0..wid-1]) [0..ht-1]

foreign import stdcall unsafe "windows.h GetDIBits"
  c_GetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT

type Font = (COLORREF, COLORREF, String, Int32, DWORD, Bool, Bool)

-- | A default font option
defFont :: Font
defFont = (defBackground, 0, "Tahoma", 14, fW_NORMAL, False, False)

-- | Draw some text at the point in the bitmap.
textOut :: String -> POINT -> Font -> Draw ()
textOut text pt (bgclr, fgclr, font, sz, weight, italic, underline) = void $ Draw $ ask >>= \tup -> lift $ do
	-- This procedure draws the text in a DDB, grabs that DDB into a DIB, then masks it into the original image.
	dc <- getDC Nothing
	finally
	 (do
	 cdc <- createCompatibleDC (Just dc)
	 finally
	  (withRECT (0, 0, 32767, 32767) $ \p -> do
	  setBkColor cdc bgclr
	  setTextColor cdc fgclr
	  fhdl <- createFont (sz * 72 `quot` 96) 0 0 0 weight italic underline False dEFAULT_CHARSET 0 0 0 0 font
	  finally
	   (do
	   oldFont <- selectFont cdc fhdl
	   finally
	    (do
	    -- Measure text
	    withTStringLen text $ \(s, l) -> c_DrawText cdc s (fromIntegral l) p dT_CALCRECT
	    -- Create a DDB
	    rt@(_, _, x, y) <- peekRECT p
	    bmp <- createCompatibleBitmap dc x y
	    finally
	     (runReaderT
		(unDraw $ mask 1 pt $ fst $ onNewBitmap (x, y) $ Draw $ ask >>= \(_, pbits, _) -> lift $ do
			oldBmp <- selectBitmap cdc bmp
			finally
			 (do
			 drawText cdc text rt 0
			 withBITMAP (bmpBitmapInfo (pack x y B.empty)) $ \p -> c_GetDIBits cdc bmp 0 y (castPtr pbits) p dIB_RGB_COLORS)
				(selectBitmap cdc oldBmp))
		tup)
		(deleteBitmap bmp))
		(selectFont cdc oldFont))
		(deleteFont fhdl))
		(deleteDC cdc))
		(releaseDC Nothing dc)

-- | Get the dimensions of a piece of text in a given font. (Note: this may be slightly different
--   on different platforms).
textDimensions :: String -> Font -> POINT
textDimensions text (_, _, font, sz, weight, italic, underline) = unsafePerformIO $ do	
	dc <- getDC Nothing
	finally
	 (do
	 fhdl <- createFont (sz * 72 `quot` 96) 0 0 0 weight italic underline False dEFAULT_CHARSET 0 0 0 0 font
	 finally
	  (do
	  oldFont <- selectFont dc fhdl
	  finally
	   (withRECT (0, 0, 32767, 32767) $ \p -> do
		withTStringLen text $ \(s, l) -> c_DrawText dc s (fromIntegral l) p dT_CALCRECT
		(_, _, x, y) <- peekRECT p
		return (x, y))
		(selectFont dc oldFont))
		(deleteFont fhdl))
		(releaseDC Nothing dc)

----------------------------------------
-- Area fill

inBounds (x, y) = do
	(wid, ht) <- askDims
	return (inRange (0, wid - 1) x && inRange (0, ht - 1) y)

areaFillImpl _ [] _ _ = return ()
areaFillImpl 0 _ _ _ = return ()
areaFillImpl n frontier clrFill clrMatch = do
	mapM_ (\pt -> unsafeSetPixel pt clrFill) frontier
	let choices = concat [ [(x - 1, y), (x, y - 1), (x + 1, y), (x, y + 1)] | (x, y) <- frontier ]
	ok <- mapM (\pt -> do
		b <- inBounds pt
		if b then
				liftM (==clrMatch) (getPixel pt)
			else
				return False) choices
	areaFillImpl (n - 1) (map fst $ filter snd $ zip choices ok) clrFill clrMatch

-- | Do an area fill with the given colour.
areaFill clr pt@(x, y) = do
	clrMatch <- getPixel pt
	unsafeSetPixel pt clr
	let choices = listArray (0, 3) [(x - 1, y), (x, y - 1), (x + 1, y), (x, y + 1)]
	Draw $ do
		d <- ask
		let ?seq = True
		lift $ conc_ (fmap (\choice -> runReaderT (unDraw $ areaFillImpl 10 [choice] clr clrMatch) d) choices)

----------------------------------------
-- Convolution

{-# INLINE useFilter #-}
useFilter filter shift im x y = let
		(kw, kh) = askDims' filter
		(wid, ht) = askDims' im
		halfX = kw `quot` 2
		halfY = kh `quot` 2
		x1 = (x - halfX) `max` 0
		y1 = (y - halfY) `max` 0
		x2 = (x + halfX) `min` wid
		y2 = (y + halfY) `min` ht
		shiftBy = fromIntegral (if shift then 127 else 0)
		sz = if shift then
				fromIntegral $ (y2 - y1) * (x2 - x1) * 127
			else
				sum (map (\y -> sum $ map (\x -> enTuple (getPixel' (x, y) filter))
					[0..x2-x1-1]) [0..y2-y1-1]) `max` 1 in
	shiftBy + sum (map (\y -> sum $ map (\x -> (enTuple (getPixel' (x, y) filter) - shiftBy) * enTuple (getPixel' (x1 + x, y1 + y) im)) [0..x2-x1-1]) [0..y2-y1-1]) / sz

-- | Standard convolution (with cutoffs).
convolve :: BMP -> Bool -> BMP -> Draw ()
convolve filter shift bmp = function' (\x y -> unTuple $ useFilter filter shift bmp x y)

-- | Flip the current image corner to corner.
flipped = do
	(wid, ht) <- askDims
	mapM_ (\y -> mapM_ (\x -> unsafeSwap (x, y) (wid - 1 - x, ht - 1 - y)) [0..wid-1]) [0..ht`div`2-1]

unsafeSwap pt pt2 = do
	clr <- unsafeGetPixel pt
	clr2 <- unsafeGetPixel pt2
	unsafeSetPixel pt clr2
	unsafeSetPixel pt2 clr

-- | Swaps two pixels.
swap pt pt2 = do
	clr <- getPixel pt
	clr2 <- getPixel pt2
	unsafeSetPixel pt clr2
	unsafeSetPixel pt2 clr

-- | Standard correlation
correlate :: BMP -> Bool -> BMP -> Draw ()
correlate kernel = convolve (fst $ onBitmap kernel flipped)

intensity x = rgb n n n where
	n = round $ 255 * x

-- | Gaussian blur filter.
blur :: Double -> BMP
blur sigma = fst $ onNewBitmap (2 * dist, 2 * dist) $ function' $ \x y -> intensity $ f (x - dist, y - dist) where
	dist = round (3 * sigma)
	f (x, y) = exp (-0.5 * (fromIntegral x ^ 2 + fromIntegral y ^ 2) / sigma ^ 2) / (2 * pi)

----------------------------------------
-- Bilinear resampling

instance (Num t, Num u, Num v) => Num (t, u, v) where
	(n1, n2, n3) + (m1, m2, m3) = (n1 + m1, n2 + m2, n3 + m3)
	negate (n1, n2, n3) = (-n1, -n2, -n3)
	(n1, n2, n3) * (m1, m2, m3) = (n1 * m1, n2 * m2, n3 * m3)
	signum (n1, n2, n3) = (signum n1, signum n2, signum n3)
	abs (n1, n2, n3) = (abs n1, abs n2, abs n3)
	fromInteger n = (fromInteger n, fromInteger n, fromInteger n)

instance (Fractional t, Fractional u, Fractional v) => Fractional (t, u, v) where
	fromRational n = (fromRational n, fromRational n, fromRational n)
	recip (n1, n2, n3) = (recip n1, recip n2, recip n3)

enTuple :: COLORREF -> (Fixed E6, Fixed E6, Fixed E6)
enTuple x = (fromIntegral $ getRValue x, fromIntegral $ getGValue x, fromIntegral $ getBValue x)

unTuple :: (Fixed E6, Fixed E6, Fixed E6) -> COLORREF
unTuple (r, g, b) = rgb (round r) (round g) (round b)

{-# INLINE weights #-}
weights f (lo, hi) = if floor lo == floor hi then
		f (floor lo)
	else fromRational (recip (hi - lo)) * (fromRational (fromIntegral (ceiling lo) - lo) * f (floor lo)
		+ fromRational (hi - fromIntegral (floor hi)) * f (floor hi)
		+ sum (map f [ceiling lo..floor hi-1]))

{-# INLINE weightsSpecial1 #-}
weightsSpecial1 factor f (lo, hi) = fromRational (recip (fromIntegral factor)) * sum (map f [ceiling lo..floor hi-1])

{-# INLINE weightsSpecial2 #-}
weightsSpecial2 f (lo, _) = f (floor lo)

{-# INLINE weightsSpecial3 #-}
weightsSpecial3 f (lo, hi) = fromRational (recip (hi - lo)) * (fromRational (fromIntegral (ceiling lo) - lo) * f (floor lo)
	+ fromRational (hi - fromIntegral (floor hi)) * f (floor hi)
	+ sum (map f [ceiling lo..floor hi-1]))

-- | Averages over the pixels in the given rectangle.
{-# INLINE sample #-}
sample weights im ((loX, loY), (hiX, hiY)) = unTuple $ weights (\y -> weights (\x -> enTuple $ getPixel' (x, y) im) (loX, hiX)) (loY, hiY)

rescale2 hi hi2 x = fromIntegral (x * (hi2 + 1)) / fromIntegral (hi + 1)

-- | Rescales a coordinate by moving it from the given first rectangle to the proportionate spot in the second rectangle.
rescale (hiX, hiY) (hiX2, hiY2) (x, y) = (rescale2 hiX hiX2 x, rescale2 hiY hiY2 y)

down1 (x, y) = (x - 1, y - 1)

-- | Resamples the given image into the current image.
resample :: BMP -> Draw ()
resample im = do
	bnds <- askDims
	if bnds == askDims' im then
			mask 1 (0, 0) im
		else let (factor, m) = divMod (fst (askDims' im)) (fst bnds) in
			function' $ \x y -> sample
				-- These are optimizations for the case when the input image is an integral multiple of the output in size...
				(if m == 0 && snd (askDims' im) `mod` snd bnds == 0 then
					weightsSpecial1 factor
				-- and the opposite...
				else if fst bnds `mod` fst (askDims' im) == 0 && snd bnds `mod` snd (askDims' im) == 0 then
					weightsSpecial2
				-- and for when the image is being downsampled.
				else if fst bnds < fst (askDims' im) && snd bnds < snd (askDims' im) then
					weightsSpecial3
				else
					weights)
				im (rescale (down1 bnds) (down1 $ askDims' im) (x, y), rescale (down1 bnds) (down1 $ askDims' im) (x + 1, y + 1))

horzGradient = fst $ onNewBitmap (3, 3) $ function' $ \x _ -> intensity (fromIntegral x / 2)

vertGradient = fst $ onNewBitmap (3, 3) $ function' $ \_ y -> intensity (fromIntegral y / 2)

laplacian = fst $ onNewBitmap (3, 3) $ function' $ curry (listArray ((0, 0), (2, 2)) [0,-1,0,-1,10,-1,0,-1,0] !)

----------------------------------------
-- Quadratic splines

stepsI :: Int
stepsI = 100

steps :: Double
steps = fromIntegral stepsI

graph (ax, ay, len) (x, y, direction, ddydirection, dy, t) = (x + direction / steps, y + direction * dy / steps, direction, ddydirection, dy + 2 * direction * ddydirection * ay / ax * step, t + step) where
	step = sqrt (1 + dy ^ 2) / len / steps

-- Compute pixel intensities for a piece of the spline.
-- TODO: Some parameter signs and flags need to be twiddled for the various quadrants, so this doesn't work currently.
intensities _ [] _ = []
intensities swapped (parm@(ax, bx, cx, ay, by, cy):parms) tuple =
	-- The intensities made by 'graph' only make sense in a certain range,
	-- so when you get to a 45 degree angle, you switch x and y.
	processed ++ if t >= 1 then
		intensities swapped parms (x, y, direction, direction * ddydirection, dy, 0)
	else
		intensities (not swapped) ((ay, by, cy, ax, bx, cx):parms) (y, x, signum dy * direction, direction * ddydirection, recip dy, t)
	where
	(ok, (x, y, direction, ddydirection, dy, t):_) = break (\(_, _, _, _, dy, t) -> abs dy > 1 || t >= 1) $ iterate (graph (ax, ay, len parm)) tuple
	processed = map (\(x, y, _, _, _, _) -> let
		(y', n) = properFraction y
		(a, b) = if swapped then (y', floor x) else (floor x, y') in
		-- Intensity can't be 0, or we can't area fill.
		((a, b), recip 255 `max` if {-(dx > 0) == -}dy > 0 then 1 - n else n)) ok

rotate1 ls = tail ls ++ [head ls]

unrotate1 ls = last ls : init ls

pairUp ls = zip ls (rotate1 ls)

-- Compute the length of a piece of the spline.
len (a, b, _, c, d, _) = f 1 - f 0 where
	f t = x t * (a ^ 2 * t + a * b + c * (c * t + d)) / 2 / (a ^ 2 + c ^ 2) + 1 / 2 / (a ^ 2 + c ^ 2) ** 1.5 * (b * c - a * d) ^ 2 * log (sqrt (a ^ 2 + c ^ 2) * x t + a ^ 2 * t + a * b + c ^ 2 * t + c * d)
	x t = sqrt (t ^ 2 * (a ^ 2 + c ^ 2) + 2 * a * b * t + b ^ 2 + 2 * c * d * t + d ^ 2)

windows _ [] = []
windows n ls = tk : windows n dr where
	(tk, dr) = splitAt n ls

-- Draw the fringe of a spline.
drawAA aa parms@((_, bx, cx, _, by, cy):_) = mapM_ (\(pt, i) -> (if aa then blend i else setPixel) pt (rgb 255 255 255))
	$ map head $ windows stepsI $ drop (stepsI `quot` 2)
	$ intensities
		False
		parms
		(cx, cy, 1, 1, by / bx, 0)

-- Compute parameters of the spline.
splineCoefficients = tail . scanl (\(accel, slope, _) (x1, x2) -> let slope' = 2 * accel + slope in
	(x2 - x1 - slope', slope', x1)) (0, 0, 0) . pairUp

-- | Draw an antialiased filled spline.
-- The first knot should be roughly at the bottom of the spline, and they should
-- go around counter clockwise.
spline aa clr knots = do
	let parmX = unrotate1 $ splineCoefficients $ rotate1 $ map fst knots
	let parmY = splineCoefficients $ map snd knots
	let parameters = zipWith (\(ax, bx, cx) (ay, by, cy) -> (ax, bx, cx, ay, by, cy)) parmX parmY
	dims <- askDims
	let (bmp, _) = onNewBitmap dims $ do
		drawAA aa parameters
		-- areaFill (rgb 255 255 255) (ceiling *** ((+1) . ceiling) $ head knots)
	mask 1 (0, 0) bmp

----------------------------------------
-- Basic shapes

clipRect (x1, y1, x2, y2) (x1a, y1a, x2a, y2a) = (x1 `max` x1a, y1 `max` y1a, x2 `min` x2a, y2 `min` y2a)

-- | Fill a rectangle.
fillRect clr rect = do
	(wid, ht) <- askDims
	function rect (\_ _ _ -> clr)

-- | Fill using a functional.
function :: (Int32, Int32, Int32, Int32) -> (COLORREF -> Int32 -> Int32 -> COLORREF) -> Draw ()
function rt f = Draw $ do
	d <- ask
	let ?seq = True
	(wid, ht) <- unDraw askDims
	let (x1, y1, x2, y2) = clipRect rt (0, 0, wid, ht)
	lift $ concF_ (fromIntegral (y2 - y1)) (\y -> mapM_ (\x -> runReaderT (unDraw $ unsafeGetPixel (x, fromIntegral y + y1) >>= \c -> unsafeSetPixel (x, fromIntegral y + y1) (f c x (fromIntegral y + y1))) d) [x1..x2-1])

function' f = do
	(wid, ht) <- askDims
	function (0, 0, wid, ht) (const f)

mean x y = (y - x) / 2 + x

-- | A filled ellipse.
ellipse aa clr (x1, y1, x2, y2) = spline aa clr [(mean x1 x2, y1), (x2, mean y1 y2), (mean x1 x2, y2), (x1, mean y1 y2)]

----------------------------------------
-- Drawing in a device context.

drawBitmap wnd hdc wd ht p = do
	let wd32 = fromIntegral wd
	let ht32 = fromIntegral ht
	-- Draw the bitmap
	withBITMAP (InfoV3 (BitmapInfoV3 40 wd ht False 1 24 CompressionRGB (4 * wd32 * ht32) 0 0 0 0)) $ \pBmp ->
		c_SetDIBitsToDevice hdc 0 0 wd32 ht32 0 0 0 ht32 p pBmp dIB_RGB_COLORS

-- | Put up a quick window to visualize the drawing as it's being drawn.
graffito (x1, y1, x2, y2) d = do
	chn <- newChan
	wnd <- frameWindow Nothing Nothing nullPtr "Graffito" $ \wnd msg wParam lParam -> do
		if msg == wM_CREATE then do
			moveWindow wnd (fromIntegral x1) (fromIntegral y1) (fromIntegral (x2 - x1)) (fromIntegral (y2 - y1)) True
			else if msg == wM_PAINT then
				allocaPAINTSTRUCT $ \ps -> do
					hdc <- beginPaint wnd ps
					forkIO $ runReaderT (unDraw d) ((x2 - x1, y2 - y1), nullPtr, Just chn) >> writeChan chn (-1, 0, 0)
					let loop = do { (x, y, clr) <- readChan chn; when (x >= 0) $ do { set hdc x (y2 - y1 - 1 - y) clr; loop } } in
						loop
					endPaint wnd ps
			else if msg == wM_CLOSE then
				void $ postMessage nullPtr wM_QUIT 0 0
			else
			return ()
		defWindowProc (Just wnd) msg wParam lParam
	postMessage wnd wM_CREATE 0 0
	allocaMessage $ \msg ->
		let loop =
			do
				b <- getMessage msg Nothing
				when b $ do
					translateMessage msg
					dispatchMessage msg
					loop in
			loop