DrawPrimitive.lhs

> module Barrie.DrawPrimitive
>     (DrawFunction, Picture, Colour,
>      background,
>      setForeground,
>      lineTo, moveTo, line, lineWidth, move, rectangle, polygon,
>      multiLine, circle,
>      image, showText,
>      black, white, fromRGB,
>      doDraw)
>     where

> import qualified Graphics.UI.Gtk as Gtk

> type Picture = Gtk.Pixmap

> data Colour = RGB Int Int Int deriving (Eq)

> black, white :: Colour
> black = fromRGB 0 0 0
> white = fromRGB 65535 65535 65535

> data DrawPrimitive = Background Colour
>                    | SetForeground Colour
>                    | SetLineThickness Int
>                    | Line Int Int
>                    | LineTo Int Int
>                    | LineWidth Int
>                    | Move Int Int
>                    | MoveTo Int Int
>                    | Polygon Bool [(Int, Int)]
>                    | Circle Bool Int
>                    | Rectangle Bool Int Int
>                    | ShowText String
>                    | Image String
>                      deriving (Eq)

> type DrawFunction = [DrawPrimitive] -> [DrawPrimitive]

> background :: Colour -> DrawFunction
> lineTo, moveTo, line, move :: Int -> Int -> DrawFunction
> lineWidth :: Int -> DrawFunction
> rectangle :: Bool -> Int -> Int -> DrawFunction
> polygon :: Bool -> [(Int, Int)] -> DrawFunction
> circle :: Bool -> Int -> DrawFunction
> showText :: String -> DrawFunction
> image :: String -> DrawFunction
> multiLine :: [(Int,Int)] -> DrawFunction
> setForeground :: Colour -> DrawFunction

> background colour xs = Background colour : xs
> lineTo x y xs = LineTo x y : xs
> moveTo x y xs = MoveTo x y : xs
> line x y xs = Line x y : xs
> lineWidth w xs = LineWidth w : xs
> move x y xs = Move x y : xs
> rectangle filled width height xs = Rectangle filled width height : xs
> polygon filled pts xs = Polygon filled pts : xs
> circle filled r xs = Circle filled r : xs
> showText text xs = ShowText text : xs
> image pic = (:) (Image pic)

> multiLine [] = id
> multiLine ((x, y):pts) = moveTo x y . foldl (.) id (map (uncurry lineTo) pts)

> setForeground col xs = SetForeground col : xs

> fromRGB :: Int -> Int -> Int -> Colour
> fromRGB = RGB

> toGtkColour :: Colour -> IO Gtk.Color
> toGtkColour (RGB r g b) = return $ Gtk.Color (cvt r) (cvt g) (cvt b)
>                                      where cvt = fromInteger . toInteger

> doDraw :: Gtk.Pixmap
>        -> Gtk.GC
>        -> Gtk.PangoContext
>        -> (Int,Int)
>        -> [DrawPrimitive]
>        -> IO ()
> doDraw _ _ _ _ [] = return ()
> doDraw win gc context (x,y) (p:ps) = do (newP,newGC) <- drawPrimitive p
>                                         doDraw win newGC context newP ps
>     where noChange = return ((x,y),gc)
>           drawPrimitive (MoveTo x' y') = return ((x', y'), gc)
>           drawPrimitive (Move dx dy)   = return ((x + dx, y + dy), gc)
>           drawPrimitive (LineTo x' y') = do
>             Gtk.drawLine win gc (x,y) (x',y')
>             return ((x',y'), gc)
>           drawPrimitive (Line dx dy) = do
>             let (x',y') = (x + dx, y + dy)
>             Gtk.drawLine win gc (x,y) (x', y')
>             return ((x',y'), gc)
>           drawPrimitive (LineWidth w) = do
>             Gtk.gcSetValues gc Gtk.newGCValues { Gtk.lineWidth = w }
>             return ((x,y), gc)
>           drawPrimitive (Rectangle filled width height) = do
>             Gtk.drawRectangle win gc filled x y width height
>             noChange
>           drawPrimitive (Polygon _ []) = noChange
>           drawPrimitive (Polygon filled pts) = do
>             Gtk.drawPolygon win gc filled pts
>             return (last pts, gc)
>           drawPrimitive (Circle filled r) = do
>             Gtk.drawArc win gc filled (x - r) (y - r)
>                    (r * 2) (r * 2) 0 (360 * 64)
>             return ((x,y),gc)
>           drawPrimitive (ShowText text) = do
>             layout <- Gtk.layoutText context text
>             layoutLine <- Gtk.layoutGetLine layout 0
>             Gtk.drawLayoutLine win gc x y layoutLine
>             return ((x,y),gc)
>           drawPrimitive (SetForeground colour) = do
>             col <- toGtkColour colour
>             Gtk.gcSetValues gc $ Gtk.newGCValues {
>               Gtk.foreground = col
>               }
>             return ((x,y),gc)
>           drawPrimitive (Background colour) = do
>             backgc <- Gtk.gcNew win
>             gtkColour <- toGtkColour colour
>             Gtk.gcSetValues backgc Gtk.newGCValues {
>               Gtk.foreground = gtkColour
>             }
>             (width, height) <- Gtk.drawableGetSize win
>             Gtk.drawRectangle win backgc True 0 0 width height
>             Gtk.drawRectangle win backgc False 0 0 width height
>             return ((x,y),gc)
>           drawPrimitive (Image pic) = do
>             pb <- Gtk.pixbufNewFromFile pic
>             Gtk.drawPixbuf win gc pb 0 0 x y (-1) (-1) Gtk.RgbDitherNormal 0 0
>             return ((x,y),gc)