Menu
▾
▴
[htoolkit-cvs] gio/src/Graphics/UI/GIO Attributes.hs,1.9,1.10 Canvas.hs,1.8,1.9 Controls.hs,1.10,1.11 Types.hs,1.9,1.10 Window.hs,1.15,1.16
|
From: <kr_...@us...> - 2003-05-30 11:43:02
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv27279/src/Graphics/UI/GIO
Modified Files:
Attributes.hs Canvas.hs Controls.hs Types.hs Window.hs
Log Message:
The high level canvas API is rewritten to get better performance
Index: Attributes.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Attributes.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Attributes.hs 23 Apr 2003 21:48:46 -0000 1.9
--- Attributes.hs 30 May 2003 11:39:08 -0000 1.10
***************
*** 48,67 ****
, frame, position, size, width, height
! -- ** Colored
! , Colored, color
!
! -- ** Background
! , Background, bgcolor
! , Filled, hatch
!
! -- ** Literate
! , Literate, text, font
-- ** Titled
, Titled, title
- -- ** Drawn
- , Drawn, thickness
-
-- ** Able
, Able, enabled
--- 48,61 ----
, frame, position, size, width, height
! -- ** HasFont
! , HasFont, font
!
! -- ** Drawn
! , Drawn, pen, color, bgcolor, hatch
! , thickness, capstyle, linestyle, joinstyle
-- ** Titled
, Titled, title
-- ** Able
, Able, enabled
***************
*** 219,258 ****
height :: Attr w Int
height = mapAttr (\(Size w h) -> h) (\(Size w _) h -> Size w h) size
- -- | Widgets with a foreground color.
- class Colored w where
-- | The (fore ground) color of the widget.
color :: Attr w Color
!
! -- | Widgets with a background color.
! class Background w where
-- | The back ground color.
bgcolor :: Attr w Color
- -- | Widgets that can be filled with a pattern.
- class Filled w where
-- | The hatch style.
hatch :: Attr w HatchStyle
- -- | Objects that are drawn.
- class Drawn w where
-- | The thickness of the drawing pencil.
thickness :: Attr w Int
! {-
-- | The cap style.
capstyle :: Attr w CapStyle
-- | The line style.
linestyle :: Attr w LineStyle
-- | The join style.
joinstyle :: Attr w JoinStyle
! -}
!
! -- | Widgets with a text.
! class Literate w where
! -- | The text.
! text :: Attr w String
! -- | The font.
! font :: Attr w Font
-- | Widgets with a title.
class Titled w where
--- 213,260 ----
height :: Attr w Int
height = mapAttr (\(Size w h) -> h) (\(Size w _) h -> Size w h) size
+
+ -- | Widgets with a font.
+ class HasFont w where
+ -- | The font.
+ font :: Attr w Font
+
+ class HasFont w => Drawn w where
+ -- | The pen
+ pen :: Attr w Pen
-- | The (fore ground) color of the widget.
color :: Attr w Color
! color = mapAttr penColor (\pen c -> pen{penColor=c}) pen
!
-- | The back ground color.
bgcolor :: Attr w Color
+ bgcolor = mapAttr penBackColor (\pen c -> pen{penBackColor=c}) pen
-- | The hatch style.
hatch :: Attr w HatchStyle
+ hatch = mapAttr penHatchStyle (\pen h -> pen{penHatchStyle=h}) pen
-- | The thickness of the drawing pencil.
thickness :: Attr w Int
! thickness = mapAttr penSize (\pen n -> pen{penSize=n}) pen
!
-- | The cap style.
capstyle :: Attr w CapStyle
+ capstyle = mapAttr penCapStyle (\pen s -> pen{penCapStyle=s}) pen
+
-- | The line style.
linestyle :: Attr w LineStyle
+ linestyle = mapAttr penLineStyle (\pen s -> pen{penLineStyle=s}) pen
+
-- | The join style.
joinstyle :: Attr w JoinStyle
! joinstyle = mapAttr penJoinStyle (\pen s -> pen{penJoinStyle=s}) pen
!
! drawMode :: Attr w DrawMode
! drawMode = mapAttr penMode (\pen m -> pen{penMode=m}) pen
+ bkDrawMode :: Attr w Bool
+ bkDrawMode = mapAttr penBkDrawMode (\pen m -> pen{penBkDrawMode=m}) pen
+
-- | Widgets with a title.
class Titled w where
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** Canvas.hs 30 May 2003 08:23:08 -0000 1.8
--- Canvas.hs 30 May 2003 11:39:08 -0000 1.9
***************
*** 1,8 ****
-----------------------------------------------------------------------------------------
{-| Module : Canvas
! Copyright : (c) Daan Leijen 2003
License : BSD-style
! Maintainer : da...@cs...
Stability : provisional
Portability : portable
--- 1,8 ----
-----------------------------------------------------------------------------------------
{-| Module : Canvas
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 16,28 ****
> where
> mypaint canvas updateFrame updateAreas
! > = do box (rect (pt 10 10) (pt 20 20)) [color =: red] canvas
! > line (pt 20 20) (pt 30 30) [color =: blue, thickness =: 10] canvas
A paint function (of type 'PaintFunction') takes three arguments, the canvas
(of type 'Canvas'), the bounding rectangle of the update frame and all areas that
need to be repainted.
-
- On a canvas, you can draw objects. These objects can be either solid objects, like
- 'box' and 'disc', or figures like 'rectangle' and 'circle'.
-}
-----------------------------------------------------------------------------------------
--- 16,27 ----
> where
> mypaint canvas updateFrame updateAreas
! > = do setCanvasPen canvas [color =: red]
! > fillRect (rect (pt 10 10) (pt 20 20)) canvas
! > setCanvasPen canvas [color =: blue, thickness =: 10]
! > drawLine (pt 20 20) (pt 30 30) canvas
A paint function (of type 'PaintFunction') takes three arguments, the canvas
(of type 'Canvas'), the bounding rectangle of the update frame and all areas that
need to be repainted.
-}
-----------------------------------------------------------------------------------------
***************
*** 30,56 ****
(
-- * Canvas
! Canvas, Pen(..)
! , pen, pencolor, penthickness, penfont
!
! -- * Canvas items
! -- ** Solids
! , Box, box
! , Oval, oval, disc
! , Pie, pie
! , Polygon, polygon
!
! -- ** Figures
! , Line, line
! , Rectangle, rectangle
! , Ellipse, ellipse, circle
! , Arc, arc
! , Polyline, polyline
! -- ** Text
! , Write, write
- -- ** Bitmaps
- , bitmap
-
-- * Font metrics
, fontMetrics
--- 29,53 ----
(
-- * Canvas
! Canvas, CanvasPen, Pen(..)
! , setCanvasPen, getCanvasPen
! -- * Drawing primitives
! , drawString
! , drawLine
! , drawPolyline
! , drawRect
! , fillRect
! , drawOval
! , drawEllipse
! , drawCircle
! , fillOval
! , fillEllipse
! , fillCircle
! , drawCurve
! , drawArc
! , fillPie
! , drawPolygon
! , drawBitmap
-- * Font metrics
, fontMetrics
***************
*** 58,64 ****
, fontStringWidth
! , penfontMetrics
! , penfontCharWidth
! , penfontStringWidth
-- * Internal
--- 55,61 ----
, fontStringWidth
! , canvasFontMetrics
! , canvasFontCharWidth
! , canvasFontStringWidth
-- * Internal
***************
*** 73,111 ****
import Control.Monad( when )
! {--------------------------------------------------------------------
! Classes
! --------------------------------------------------------------------}
- {--------------------------------------------------------------------
-
- --------------------------------------------------------------------}
-- | A canvas is an area on which you can draw objects.
data Canvas = Canvas{ hcanvas :: CanvasHandle
, vpen :: Var Pen
}
! -- | The current drawing pencil.
! pen :: Attr Canvas Pen
! pen = newAttr getter setter
! where
! getter c = getVar (vpen c)
! setter c p = do oldpen <- takeVar (vpen c)
! when (p /= oldpen) (Port.changeCanvasPen p (hcanvas c))
! putVar (vpen c) p
! -- | The current drawing color.
! pencolor :: Attr Canvas Color
! pencolor
! = attrPenColor pen
! -- | The current pencil size.
! penthickness :: Attr Canvas Int
! penthickness
! = attrPenThickness pen
-- | The current font.
! penfont :: Attr Canvas Font
! penfont
! = attrPenFont pen
-- | The font metrics (read-only).
--- 70,102 ----
import Control.Monad( when )
! --------------------------------------------------------------------
! -- Canvas
! --------------------------------------------------------------------
-- | A canvas is an area on which you can draw objects.
data Canvas = Canvas{ hcanvas :: CanvasHandle
, vpen :: Var Pen
}
+ newtype CanvasPen = CanvasPen (Var Pen)
! instance Drawn CanvasPen where
! pen = newAttr (\(CanvasPen vpen) -> getVar vpen)
! (\(CanvasPen vpen) -> setVar vpen)
! instance HasFont CanvasPen where
! font = mapAttr penFont (\pen c -> pen{penFont=c}) pen
! setCanvasPen :: Canvas -> [Prop CanvasPen] -> IO ()
! setCanvasPen (Canvas handle vpen) props = do
! set (CanvasPen vpen) props
! pen <- getVar vpen
! Port.changeCanvasPen pen handle
+ getCanvasPen :: Canvas -> Attr CanvasPen a -> IO a
+ getCanvasPen (Canvas handle vpen) = get (CanvasPen vpen)
+
-- | The current font.
! penfont :: Attr CanvasPen Font
! penfont = mapAttr penFont (\pen c -> pen{penFont=c}) pen
-- | The font metrics (read-only).
***************
*** 114,118 ****
--
fontMetrics :: Font -> Attr Canvas FontMetrics
! fontMetrics font
= readAttr "fontMetrics" $ \canvas -> Port.getFontMetrics font (hcanvas canvas)
--- 105,109 ----
--
fontMetrics :: Font -> Attr Canvas FontMetrics
! fontMetrics font
= readAttr "fontMetrics" $ \canvas -> Port.getFontMetrics font (hcanvas canvas)
***************
*** 128,314 ****
-- | The font metrics of the current drawing pencil (read-only).
! penfontMetrics :: Attr Canvas FontMetrics
! penfontMetrics
= readAttr "penfontMetrics" $ \canvas -> Port.getPenFontMetrics (hcanvas canvas)
-- | The character width in the current pen font on a canvas (read-only).
--
! -- > do em <- get canvas (penfontCharWidth 'm')
! penfontCharWidth ::Char -> Attr Canvas Int
! penfontCharWidth c
= readAttr "penfontCharWidth" $ \canvas -> Port.getPenFontCharWidth c (hcanvas canvas)
-- | The string width in the current pen font on a canvas (read-only).
! penfontStringWidth :: String -> Attr Canvas Int
! penfontStringWidth s
= readAttr "penfontStringWidth" $ \canvas -> Port.getPenFontStringWidth s (hcanvas canvas)
-- Paint on a primitive canvas. Just for internal use.
! withCanvas :: CanvasHandle -> BufferMode -> Color -> Color -> HatchStyle -> (Canvas -> IO ()) -> IO ()
! withCanvas handle bmode fgcolor bgcolor hatch f
! = do c <- createCanvas handle p
! Port.initCanvas p bmode handle
! f c
! Port.doneCanvas handle
! where
! p = Port.defaultPen{ Port.penColor = fgcolor
! , Port.penBackColor = bgcolor
! , Port.penHatchStyle = hatch }
!
! defaultCanvas :: CanvasHandle -> IO Canvas
! defaultCanvas handle
! = createCanvas handle (Port.defaultPen)
!
! createCanvas :: CanvasHandle -> Pen -> IO Canvas
! createCanvas handle p
! = do vpen <- newVar p
! return (Canvas handle vpen)
!
! {--------------------------------------------------------------------
! Helpers for drawing figures
! --------------------------------------------------------------------}
! newVarPen :: Canvas -> IO (Var Pen)
! newVarPen can
! = do p <- get can pen
! newVar p
!
! withVarPen :: Var Pen -> Canvas -> IO a -> IO a
! withVarPen vp can io
! = do p <- getVar vp
! with can [pen =: p] io
!
!
! attrPenColor :: Attr w Pen -> Attr w Color
! attrPenColor pen
! = mapAttr penColor (\p c -> p{ penColor = c }) pen
!
! attrPenBackColor :: Attr w Pen -> Attr w Color
! attrPenBackColor pen
! = mapAttr penBackColor (\p c -> p{ penBackColor = c }) pen
!
! attrPenThickness :: Attr w Pen -> Attr w Int
! attrPenThickness pen
! = mapAttr penSize (\p t -> p{ penSize = t }) pen
!
! attrPenFont :: Attr w Pen -> Attr w Font
! attrPenFont pen
! = mapAttr penFont (\p f -> p{ penFont = f }) pen
!
!
! {--------------------------------------------------------------------
! Write text
! --------------------------------------------------------------------}
! data Write = Write{ writeText :: Var String
! , writePen :: Var Pen
! }
!
! penWrite = varAttr writePen
!
! instance Colored Write where
! color = attrPenColor penWrite
!
! instance Literate Write where
! text = varAttr writeText
! font = attrPenFont penWrite
!
! write :: Point -> [Prop Write] -> Canvas -> IO ()
! write p props can
! = do vp <- newVarPen can
! vtxt <- newVar ""
! set (Write vtxt vp) props
! txt <- getVar vtxt
! withVarPen vp can (Port.drawString p txt (hcanvas can))
!
!
! {--------------------------------------------------------------------
! Figures
! --------------------------------------------------------------------}
! -- | A line.
! data Line = Line{ linePen:: Var Pen }
!
! penLine :: Attr Line Pen
! penLine = varAttr linePen
!
! instance Colored Line where
! color = attrPenColor penLine
!
! instance Drawn Line where
! thickness = attrPenThickness penLine
!
! -- | Draw a line.
! line :: Point -> Point -> [Prop Line] -> Canvas -> IO ()
! line p0 p1 props can
! = do vp <- newVarPen can
! set (Line vp) props
! withVarPen vp can (Port.drawLine p0 p1 (hcanvas can))
!
!
!
! -- | A rectangle.
! data Rectangle = Rectangle{ rectFrame :: Var Rect
! , rectPen :: Var Pen
! }
!
! penRect = varAttr rectPen
!
! instance Colored Rectangle where
! color = attrPenColor penRect
!
! instance Drawn Rectangle where
! thickness = attrPenThickness penRect
!
! instance Dimensions Rectangle where
! frame = varAttr rectFrame
! -- | Draw a rectangle.
! rectangle :: Rect -> [Prop Rectangle] -> Canvas -> IO ()
! rectangle r props can
! = do rectFrame <- newVar r
! rectPen <- newVarPen can
! set (Rectangle rectFrame rectPen) props
! frame <- getVar rectFrame
! withVarPen rectPen can (Port.drawRect frame (hcanvas can))
! -- | An ellipse
! data Ellipse = Ellipse{ ellipseFrame :: Var Rect
! , ellipsePen :: Var Pen
! }
! penEllipse = varAttr ellipsePen
! instance Colored Ellipse where
! color = attrPenColor penEllipse
! instance Drawn Ellipse where
! thickness = attrPenThickness penEllipse
! instance Dimensions Ellipse where
! frame = varAttr ellipseFrame
! -- | Draw an ellipse, given a center point and the x- and y radius.
! ellipse :: Point -> Int -> Int -> [Prop Ellipse] -> Canvas -> IO ()
! ellipse (Point x y) rx ry props can
! = do ellipseFrame <- newVar (Rect (x-rx) (y-ry) (x+rx) (y+ry))
! ellipsePen <- newVarPen can
! set (Ellipse ellipseFrame ellipsePen) props
! frame <- getVar ellipseFrame
! withVarPen ellipsePen can (Port.drawOval frame (hcanvas can))
! circle :: Point -> Int -> [Prop Ellipse] -> Canvas -> IO ()
! circle p radius props canvas
! = ellipse p radius radius props canvas
! -- | An arc
! data Arc = Arc{ arcPen :: Var Pen
! }
! penArc = varAttr arcPen
! instance Colored Arc where
! color = attrPenColor penArc
! instance Drawn Arc where
! thickness = attrPenThickness penArc
-- | Draw an arc. The expression (arc c rx ry start end [] canvas) draws a curve on the oval
--- 119,199 ----
-- | The font metrics of the current drawing pencil (read-only).
! canvasFontMetrics :: Attr Canvas FontMetrics
! canvasFontMetrics
= readAttr "penfontMetrics" $ \canvas -> Port.getPenFontMetrics (hcanvas canvas)
-- | The character width in the current pen font on a canvas (read-only).
--
! -- > do em <- get canvas (canvasFontCharWidth 'm')
! canvasFontCharWidth ::Char -> Attr Canvas Int
! canvasFontCharWidth c
= readAttr "penfontCharWidth" $ \canvas -> Port.getPenFontCharWidth c (hcanvas canvas)
-- | The string width in the current pen font on a canvas (read-only).
! canvasFontStringWidth :: String -> Attr Canvas Int
! canvasFontStringWidth s
= readAttr "penfontStringWidth" $ \canvas -> Port.getPenFontStringWidth s (hcanvas canvas)
-- Paint on a primitive canvas. Just for internal use.
! withCanvas :: BufferMode -> Pen -> CanvasHandle -> (Canvas -> IO a) -> IO a
! withCanvas bmode pen handle f
! = do vpen <- newVar pen
! Port.withCanvas pen bmode handle (f (Canvas handle vpen))
! --------------------------------------------------------------------
! -- Drawing primitives
! --------------------------------------------------------------------
! -- | Draws the specified text string at the specified location.
! drawString :: Point -> String -> Canvas -> IO ()
! drawString p txt can = Port.drawString p txt (hcanvas can)
! -- | Draws a line connecting the two points specified by coordinate pairs.
! drawLine :: Point -> Point -> Canvas -> IO ()
! drawLine p0 p1 can = Port.drawLine p0 p1 (hcanvas can)
! -- | Draws a series of line segments that connect an list of points.
! drawPolyline :: [Point] -> Canvas -> IO ()
! drawPolyline points can = Port.drawPolyline points (hcanvas can)
! -- | Draws a rectangle specified by a Rect.
! drawRect :: Rect -> Canvas -> IO ()
! drawRect frame can = Port.drawRect frame (hcanvas can)
! -- | Fills the interior of a rectangle specified by a Rect.
! fillRect :: Rect -> Canvas -> IO ()
! fillRect frame can = Port.fillRect frame (hcanvas can)
! -- | Draws an ellipse specified by a bounding rectangle.
! drawOval :: Rect -> Canvas -> IO ()
! drawOval frame can = Port.drawOval frame (hcanvas can)
! -- | Draw an ellipse specified by a center point and the x- and y radius.
! drawEllipse :: Point -> Int -> Int -> Canvas -> IO ()
! drawEllipse (Point x y) rx ry can
! = Port.drawOval (Rect (x-rx) (y-ry) (x+rx) (y+ry)) (hcanvas can)
+ -- | Draw an circle specified by a center point and the radius.
+ drawCircle :: Point -> Int -> Canvas -> IO ()
+ drawCircle (Point x y) r can
+ = Port.drawOval (Rect (x-r) (y-r) (x+r) (y+r)) (hcanvas can)
! -- | Fills the interior of an ellipse defined by a bounding rectangle specified by a Rect.
! fillOval :: Rect -> Canvas -> IO ()
! fillOval frame can = Port.fillOval frame (hcanvas can)
! -- | Fills the interior of an ellipse specified by a center point and the x- and y radius.
! fillEllipse :: Point -> Int -> Int -> Canvas -> IO ()
! fillEllipse (Point x y) rx ry can = Port.fillOval (Rect (x-rx) (y-ry) (x+rx) (y+ry)) (hcanvas can)
! -- | Fills the interior of a circle specified by a center point and the radius.
! fillCircle :: Point -> Int -> Canvas -> IO ()
! fillCircle (Point x y) r can = Port.fillOval (Rect (x-r) (y-r) (x+r) (y+r)) (hcanvas can)
! -- | Draws an curve representing a portion of an ellipse specified by a Rect. The Float type
! -- arguments specifies @start@ and @end@ angles in radians. The curve starts at an angle @start@
! -- continuing in clockwise direction to the ending angle @end@.
! drawCurve :: Rect -> Float -> Float -> Canvas -> IO ()
! drawCurve frame start end can = Port.drawCurve frame start end (hcanvas can)
-- | Draw an arc. The expression (arc c rx ry start end [] canvas) draws a curve on the oval
***************
*** 316,461 ****
-- at an angle @start@ (in radians) continuing in clockwise direction
-- to the ending angle @end@ (in radians).
! arc :: Point -> Int -> Int -> Float -> Float -> [Prop Arc] -> Canvas -> IO ()
! arc (Point x y) rx ry start end props can
! = do arcPen <- newVarPen can
! set (Arc arcPen) props
! withVarPen arcPen can (Port.drawCurve (Rect (x-rx) (y-ry) (x+rx) (y+ry)) start end (hcanvas can))
!
!
!
! -- | An poly line.
! data Polyline = Polyline{ polyPen :: Var Pen}
!
! penPolyline = varAttr polyPen
!
! instance Colored Polyline where
! color = attrPenColor penPolyline
!
! instance Drawn Polyline where
! thickness = attrPenThickness penPolyline
!
! -- | Draw a poly line.
! polyline :: [Point] -> [Prop Polyline] -> Canvas -> IO ()
! polyline points props can
! = do polyPen <- newVarPen can
! set (Polyline polyPen) props
! withVarPen polyPen can (Port.drawPolyline points (hcanvas can))
!
!
!
! {--------------------------------------------------------------------
! Solids
! --------------------------------------------------------------------}
! -- | A box.
! data Box = Box{ boxFrame :: Var Rect
! , boxPen :: Var Pen
! }
!
! penBox = varAttr boxPen
!
! instance Colored Box where
! color = attrPenColor penBox
!
! instance Dimensions Box where
! frame = varAttr boxFrame
!
! -- | Draw a box.
! box :: Rect -> [Prop Box] -> Canvas -> IO ()
! box r props can
! = do boxFrame <- newVar r
! boxPen <- newVarPen can
! set (Box boxFrame boxPen) props
! frame <- getVar boxFrame
! withVarPen boxPen can (Port.fillRect frame (hcanvas can))
!
! -- | An oval
! data Oval = Oval{ ovalFrame :: Var Rect
! , ovalPen :: Var Pen
! }
!
! penOval = varAttr ovalPen
!
! instance Colored Oval where
! color = attrPenColor penOval
!
! instance Dimensions Oval where
! frame = varAttr ovalFrame
!
! -- | Draw an oval.
! oval :: Point -> Int -> Int -> [Prop Oval] -> Canvas -> IO ()
! oval (Point x y) rx ry props can
! = do ovalFrame <- newVar (Rect (x-rx) (y-ry) (x+rx) (y+ry))
! ovalPen <- newVarPen can
! set (Oval ovalFrame ovalPen) props
! frame <- getVar ovalFrame
! withVarPen ovalPen can (Port.fillOval frame (hcanvas can))
!
!
! disc :: Point -> Int -> [Prop Oval] -> Canvas -> IO ()
! disc p radius props canvas
! = oval p radius radius props canvas
!
!
!
! -- | A pie
! data Pie = Pie{ pieFrame :: Var Rect
! , piePen :: Var Pen
! }
!
! penPie = varAttr piePen
!
! instance Colored Pie where
! color = attrPenColor penPie
!
! instance Dimensions Pie where
! frame = varAttr pieFrame
!
! -- | Draw a pie.
! pie :: Point -> Int -> Int -> Float -> Float -> [Prop Pie] -> Canvas -> IO ()
! pie (Point x y) rx ry start end props can
! = do pieFrame <- newVar (Rect (x-rx) (y-ry) (x+rx) (y+ry))
! piePen <- newVarPen can
! set (Pie pieFrame piePen) props
! frame <- getVar pieFrame
! withVarPen piePen can (Port.fillCurve frame start end (hcanvas can))
!
!
!
! -- | A polygon
! data Polygon = Polygon{ polygonPen :: Var Pen}
!
! penPolygon = varAttr polygonPen
!
! instance Colored Polygon where
! color = attrPenColor penPolygon
!
! -- | Draw a polygon.
! polygon :: [Point] -> [Prop Polygon] -> Canvas -> IO ()
! polygon points props can
! = do polygonPen <- newVarPen can
! set (Polygon polygonPen) props
! withVarPen polygonPen can (Port.fillPolygon points (hcanvas can))
!
!
!
!
! -- | Draw a bitmap
! bitmap :: Point -> Bitmap -> Canvas -> IO ()
! bitmap p bitmap can = Port.drawBitmap p bitmap (hcanvas can)
! {--------------------------------------------------------------------
! figures:
! line
! polyline
! rectangle
! ellipse
! circle
! arc
! solids
! polygon
! box
! oval
! disc
! pie
! --------------------------------------------------------------------}
--- 201,218 ----
-- at an angle @start@ (in radians) continuing in clockwise direction
-- to the ending angle @end@ (in radians).
! drawArc :: Point -> Int -> Int -> Float -> Float -> Canvas -> IO ()
! drawArc (Point x y) rx ry start end can
! = Port.drawCurve (Rect (x-rx) (y-ry) (x+rx) (y+ry)) start end (hcanvas can)
!
! -- | Fills the interior of a pie section defined by an ellipse specified by a by a center point and the x- and y radius
! -- and two radial lines at angles @start@ and @end@. The Float arguments specifies the angles.
! fillPie :: Point -> Int -> Int -> Float -> Float -> Canvas -> IO ()
! fillPie (Point x y) rx ry start end can = Port.fillCurve (Rect (x-rx) (y-ry) (x+rx) (y+ry)) start end (hcanvas can)
! -- | Draws a polygon defined by an list of points
! drawPolygon :: [Point] -> Canvas -> IO ()
! drawPolygon points can = Port.fillPolygon points (hcanvas can)
! -- | Draws the specified Bitmap at the specified location.
! drawBitmap :: Point -> Bitmap -> Canvas -> IO ()
! drawBitmap p bitmap can = Port.drawBitmap p bitmap (hcanvas can)
Index: Controls.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Controls.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Controls.hs 26 Apr 2003 20:54:00 -0000 1.10
--- Controls.hs 30 May 2003 11:39:08 -0000 1.11
***************
*** 51,56 ****
return lab
! instance Literate Label where
! text = newAttr (Port.getLabelText . lhandle) (Port.setLabelText . lhandle)
font = newAttr (getVar . lfont) (\w font -> Port.changeLabelFont (lhandle w) font >> setVar (lfont w) font)
--- 51,58 ----
return lab
! instance Titled Label where
! title = newAttr (Port.getLabelText . lhandle) (Port.setLabelText . lhandle)
!
! instance HasFont Label where
font = newAttr (getVar . lfont) (\w font -> Port.changeLabelFont (lhandle w) font >> setVar (lfont w) font)
***************
*** 87,93 ****
return but
! instance Literate Button where
! text = newAttr (\b -> Port.getButtonText (bhandle b))
! (\b txt -> Port.setButtonText (bhandle b) txt)
font = newAttr (getVar . bfont) (\w font -> Port.changeButtonFont (bhandle w) font >> setVar (bfont w) font)
--- 89,96 ----
return but
! instance Titled Button where
! title = newAttr (Port.getButtonText . bhandle) (Port.setButtonText . bhandle)
!
! instance HasFont Button where
font = newAttr (getVar . bfont) (\w font -> Port.changeButtonFont (bhandle w) font >> setVar (bfont w) font)
***************
*** 128,133 ****
return e
! instance Literate Entry where
! text = newAttr (Port.getEditText . ehandle) (Port.setEditText . ehandle)
font = newAttr (getVar . efont) (\w font -> Port.changeEditBoxFont (ehandle w) font >> setVar (efont w) font)
--- 131,138 ----
return e
! instance Titled Entry where
! title = newAttr (Port.getEditText . ehandle) (Port.setEditText . ehandle)
!
! instance HasFont Entry where
font = newAttr (getVar . efont) (\w font -> Port.changeEditBoxFont (ehandle w) font >> setVar (efont w) font)
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Types.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Types.hs 13 Apr 2003 19:12:07 -0000 1.9
--- Types.hs 30 May 2003 11:39:08 -0000 1.10
***************
*** 77,80 ****
--- 77,81 ----
, LineStyle(..)
, HatchStyle(..)
+ , Pen(..), defaultPen, dialogPen
-- ** Fonts
***************
*** 106,109 ****
--- 107,111 ----
import Graphics.UI.Port.Types
import Graphics.UI.Port.Colors
+ import Graphics.UI.Port.Canvas(Pen(..), defaultPen, dialogPen)
import Control.Concurrent.MVar
{--------------------------------------------------------------------
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -d -r1.15 -r1.16
*** Window.hs 30 May 2003 08:23:09 -0000 1.15
--- Window.hs 30 May 2003 11:39:09 -0000 1.16
***************
*** 34,43 ****
, vresizeable :: Var Bool
, vautosize :: Var Bool
! , vcolor :: Var Color
! , vbgcolor :: Var Color
! , vhatch :: Var HatchStyle
! , vpaint :: Var PaintFunction
! , vlayout :: Var Layout
, vbufferMode :: Var BufferMode
}
--- 34,41 ----
, vresizeable :: Var Bool
, vautosize :: Var Bool
! , vpen :: Var Pen
, vbufferMode :: Var BufferMode
+ , vpaint :: Var PaintFunction
+ , vlayout :: Var Layout
}
***************
*** 45,49 ****
window :: [Prop Window] -> IO Window
window props
! = do w <- Lib.createWindow >>= form
set w [bgcolor =: white]
set w props
--- 43,47 ----
window :: [Prop Window] -> IO Window
window props
! = do w <- Lib.createWindow >>= form defaultPen
set w [bgcolor =: white]
set w props
***************
*** 61,65 ****
dialog props mb_parent
= do let hparent = maybe Lib.nullHandle hwindow mb_parent
! w <- Lib.createDialog hparent >>= form
set w props
Lib.showWindow (hwindow w)
--- 59,63 ----
dialog props mb_parent
= do let hparent = maybe Lib.nullHandle hwindow mb_parent
! w <- Lib.createDialog hparent >>= form dialogPen
set w props
Lib.showWindow (hwindow w)
***************
*** 70,75 ****
runDialog w = Lib.runDialog (hwindow w)
! form :: WindowHandle -> IO Window
! form hwindow
= do w <- do vpaint <- newVar (\_ _ _ -> return ())
vautosize <- newVar True
--- 68,73 ----
runDialog w = Lib.runDialog (hwindow w)
! form :: Pen -> WindowHandle -> IO Window
! form pen hwindow
= do w <- do vpaint <- newVar (\_ _ _ -> return ())
vautosize <- newVar True
***************
*** 77,87 ****
vdomain <- newVar (sz 0 0)
vresizeable<- newVar True
! vcolor <- newVar black
! vbgcolor <- newVar dialoggray
! vhatch <- newVar HatchSolid
vbufferMode<- newVar UnBuffered
return (Window hwindow vdomain vresizeable vautosize
! vcolor vbgcolor vhatch
! vpaint vlayout vbufferMode
)
recolorWindow w
--- 75,82 ----
vdomain <- newVar (sz 0 0)
vresizeable<- newVar True
! vpen <- newVar pen
vbufferMode<- newVar UnBuffered
return (Window hwindow vdomain vresizeable vautosize
! vpen vbufferMode vpaint vlayout
)
recolorWindow w
***************
*** 161,176 ****
(\w r -> Lib.setWindowFrame (hwindow w) r)
!
! instance Colored Window where
! color = newAttr (\w -> getVar (vcolor w))
! (\w c -> do setVar (vcolor w) c; recolorWindow w)
!
! instance Background Window where
! bgcolor = newAttr (\w -> getVar (vbgcolor w))
! (\w c -> do setVar (vbgcolor w) c; recolorWindow w)
!
! instance Filled Window where
! hatch = newAttr (\w -> getVar (vhatch w))
! (\w h -> do setVar (vhatch w) h; recolorWindow w)
instance Reactive Window where
--- 156,164 ----
(\w r -> Lib.setWindowFrame (hwindow w) r)
! instance Drawn Window where
! pen = newAttr (getVar . vpen) (\w pen -> setVar (vpen w) pen >> recolorWindow w)
!
! instance HasFont Window where
! font = mapAttr penFont (\pen c -> pen{penFont=c}) pen
instance Reactive Window where
***************
*** 190,198 ****
where
wndpaint w paintfun hcanvas updArea
! = do col <- get w color
! bgcol <- get w bgcolor
! hat <- get w hatch
bmode <- get w bufferMode
! withCanvas hcanvas bmode col bgcol hat $ \can -> paintfun can updArea []
instance Able Window where
--- 178,184 ----
where
wndpaint w paintfun hcanvas updArea
! = do pen <- get w pen
bmode <- get w bufferMode
! withCanvas bmode pen hcanvas $ \can -> paintfun can updArea []
instance Able Window where
|
