DrawPrimitive.hs

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)