/[pal]/pal-gui/present.lisp
ViewVC logotype

Contents of /pal-gui/present.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Thu Jan 3 21:42:48 2008 UTC (6 years, 3 months ago) by tneste
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +2 -1 lines
Fixed some widget rendering problems. Updated the examples.
1 (in-package :pal-gui)
2
3
4 (defmethod present (object (g widget) width height)
5 (with-blend (:color *text-color*)
6 (draw-text (format nil "~a" object) (v (vx *text-offset*)
7 (- (truncate height 2) (truncate (get-font-height *gui-font*) 2) 1))
8 *gui-font*)))
9
10
11
12 (defmethod present ((image image) (g widget) width height)
13 (draw-image image (v 0 0) :scale (min (/ height (image-height image)) (/ width (image-width image)))))
14
15
16
17 (defmethod present ((s (eql :up-arrow)) (g widget) width height)
18 (draw-polygon (list (v 3 (- height 3))
19 (v (/ width 2) 3)
20 (v (- width 3) (- height 3)))
21 (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t))
22
23
24 (defmethod present ((s (eql :down-arrow)) (g widget) width height)
25 (draw-polygon (list (v 3 3)
26 (v (/ width 2) (- height 3))
27 (v (- width 3) 3))
28 (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t))
29
30
31 (defmethod present ((s (eql :right-arrow)) (g widget) width height)
32 (draw-polygon (list (v 3 3)
33 (v (- width 3) (/ height 2))
34 (v 3 (- height 3)))
35 (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t))
36
37
38 (defmethod present ((s (eql :left-arrow)) (g widget) width height)
39 (draw-polygon (list (v (- width 3) 3)
40 (v 3 (/ height 2))
41 (v (- width 3) (- height 3)))
42 (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t))
43
44
45 (defmethod present ((s (eql :box)) (g widget) width height)
46 (draw-rectangle (v 3 3) (- width 6) (- height 6) (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t))
47
48
49 (defmethod present ((s (eql :circle)) (g widget) width height)
50 (draw-circle (v (/ width 2) (/ height 2)) (/ (min width height) pi) (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t))

  ViewVC Help
Powered by ViewVC 1.1.5