/[stamp]/stamp/clim-utilities.lisp
ViewVC logotype

Contents of /stamp/clim-utilities.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Wed Dec 5 12:18:52 2007 UTC (6 years, 4 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -2 lines
Added declaim with a debug level of 3 for better source tracking.
1 ;;; clim-utilities
2
3 (in-package :stamp-gui)
4
5 (declaim (optimize (debug 3)))
6
7 (defparameter *hilight-color* (clim:make-rgb-color 0.8 0.8 1.0))
8
9 (defun redisplay-pane (name)
10 (let ((pane (clim:get-frame-pane clim:*application-frame* name)))
11 (clim:redisplay-frame-pane clim:*application-frame* pane :force-p t)))
12
13 (defun print-fixed-width-string (pane string width &key (align :left))
14 (let* ((string2 (maybe-cut-string-at-width pane string width))
15 (string2-width (clim:stream-string-width pane string2)))
16 (multiple-value-bind (cursor-x cursor-y)
17 (clim:stream-cursor-position pane)
18 (setf (clim:stream-cursor-position pane)
19
20 (values (case align
21 (:left cursor-x)
22 (:center (+ cursor-x (floor (- width string2-width) 2)))
23 (:right (+ cursor-x (- width string2-width))))
24 cursor-y))
25 (write-string string2 pane)
26 (setf (clim:stream-cursor-position pane)
27 (values (+ cursor-x width) cursor-y)))))
28
29 (defun maybe-cut-string-at-width (pane string max-width)
30 (loop for index downfrom (length string)
31 as string2 = (if (= index (length string))
32 string
33 (concatenate 'string (subseq string 0 index) "..."))
34 as string2-width = (clim:stream-string-width pane string2)
35 until (<= string2-width max-width)
36 finally (return string2)))
37
38 (defun print-properties-as-table (pane properties)
39 (clim:formatting-table (pane :x-spacing 10)
40 (loop for property in properties
41 do (clim:formatting-row (pane)
42 (clim:with-text-face (pane :bold)
43 (clim:formatting-cell (pane :align-x :right)
44 (write-string (car property) pane)))
45 (clim:formatting-cell (pane)
46 (write-string (cdr property) pane))))))
47
48 (defun hilight-line (pane y)
49 (multiple-value-bind (pane-x1 pane-y1 pane-x2 pane-y2)
50 (clim:bounding-rectangle* pane)
51 (declare (ignore pane-y1 pane-y2))
52 (let ((height (clim:text-style-height clim:*default-text-style* pane)))
53 (clim:draw-rectangle* pane
54 pane-x1 y pane-x2 (+ y height 1)
55 :filled t :ink *hilight-color*))))
56
57
58
59
60
61
62
63

  ViewVC Help
Powered by ViewVC 1.1.5