/[cello]/cello/ix-text.lisp
ViewVC logotype

Contents of /cello/ix-text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Mon Jun 16 12:39:21 2008 UTC (5 years, 10 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.12: +20 -13 lines
nothing special
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 ;===========================================================
20
21 (eval-when (compile load eval)
22 (export '(ix-paint inset ix-text ix-styled ix-view)))
23
24 (defmodel ix-text (ix-styled ix-view)
25 (
26 (text$ :initform nil :initarg :text$ :accessor text$)
27
28 (display-text$ :initform (c? (remove-if-not #'graphic-char-p (^text$)))
29 :initarg :display-text$ :accessor display-text$)
30
31 (text-width :initarg :text-width :accessor text-width
32 :initform (c? (bwhen (t$ (^display-text$))
33 (ix-string-width self t$))))
34
35 (char-mask :cell nil :initarg :char-mask
36 :initform nil
37 :reader char-mask)
38
39 (maxcharwidth :initarg :maxcharwidth
40 :initform (c? (ix-string-width self "M"))
41 :accessor maxcharwidth)
42
43 (wrapp :initform nil :accessor wrapp :cell nil :initarg :wrapp)
44
45 (justify-hz :initform :left
46 :accessor justify-hz
47 :initarg :justify-hz)
48
49 (justify-vt :initform :top
50 :accessor justify-vt :initarg :justify-vt)
51
52 (inset :cell nil :initarg :inset
53 :unchanged-if 'v2=
54 :initform (mkv2 0 0)
55 :accessor inset)
56 (ll :initform (c? (- (inset-h self))))
57 (lt :initform (c? (eko (nil "ixtext lt")
58 (ups 0 (font-ascent (text-font self)) (inset-v self)))))
59 (lr :initform (c? (eko (nil "ix-text lr")
60 (^lr-width (+ (cond
61 ((char-mask self) (ix-string-width self (char-mask self)))
62 ((^text-width))
63 ((^maxcharwidth))
64 (t (error "Please specify a font or :lr <n>.")))
65 (* 2 (inset-h self)))))))
66 (lb :initform (c? (eko (nil "ixtext LB")
67 (downs (font-descent (text-font self)) (inset-v self)))))
68 )
69 (:default-initargs
70 :lighting :off))
71
72 (export! a-label text$ ^text$)
73
74 (defmacro a-label (text$ &rest key-arg-pairs)
75 `(make-kid 'ix-text
76 ,@key-arg-pairs
77 :style-id :label
78 :text$ ,text$))
79
80 (defmethod display-text$ :around ((self ix-text))
81 (or (call-next-method)
82 (text$ self)))
83
84 (defmethod ix-paint ((self ix-text))
85 (when (display-text$ self)
86 (ix-render-in-font (text-font self) self)))
87
88
89 (defmethod ix-align-text (self font)
90 (declare (ignorable font))
91 (flet ((hxs ()
92 (- (l-width self) (* 2 (v2-h (inset self))) (^text-width)))
93 (vxs ()
94 (- (l-height self) (* 2 (v2-h (inset self))) (font-height font))))
95 (gl-translatef
96 (ecase (justify-hz self)
97 (:left 0)
98 (:center (/ (hxs) 2.0))
99 (:right (hxs)))
100 (ecase (justify-vt self)
101 (:top 0)
102 (:center (downs (/ (vxs) 2.0)))
103 (:bottom (downs (vxs))))
104 0)))
105
106
107
108 #+(or)
109 (format nil "~3,1f" pi)
110
111 (defmodel ix-text-tall (ix-text)
112 ((text-height :reader text-height
113 :initarg :text-height)
114 (formatted$ :reader formatted$
115 :initarg :formatted$)
116 (wrapp :initform t))
117 (:default-initargs
118 :lb (c? (downs (text-height self)
119 (inset-v (inset self))))
120 :formatted$ (c? (bif (text$ (^text$))
121 (wrap$ text$
122 (- (^lr) (inset-h (inset self)))
123 (target-res (s-canvas)) (^text-font))
124 ""))
125 :text-height (c? (bif (text$ (^formatted$))
126 (* (font-height (text-font self))
127 (1+ (count #\newline text$)))
128 0))))
129
130 (defun wrap$ (s w res font)
131 (declare (ignorable w res font))
132 s)
133
134 (export! *menus* find-menu)
135
136 (defparameter *menus* nil) ;; set this at make-instance time in the kids rule of the window
137
138 (defun find-menu (id)
139 (fm-find-one *menus* id :must-find t :skip-tree nil :global-search nil :test #'cells::true-that))
140
141 (defun make-string-tool-tip (self s)
142 (make-kid 'ix-text
143 :inset 3
144 :style-id :label
145 :pre-layer (with-layers
146 +yellow+
147 :fill
148 (:frame-3d :edge-raised
149 :thickness 2)
150 +black+)
151 :text$ s))
152
153 (defmd tool-tip (ix-stack)
154 :visible (c? (^kids))
155 :kids (c? (the-kids
156 (bwhen (v (mouse-view .og.))
157 (when (tool-tip-show? v)
158 (typecase (tool-tip v)
159 (null)
160 (string
161 (make-string-tool-tip self (tool-tip v)))
162 (t (funcall (tool-tip v) self v)))))))
163
164 ;
165 ; tedious geometry stuff to keep tool tip
166 ; visible yet not eclipsed by mouse pointer
167 ;
168 :px (let (fixed)
169 (c? (bwhen (mp (mouse-pos .og.))
170 (cond
171 ((^visible)
172 .retog.
173 (or fixed (setf fixed
174 (let ((pref (+ 6 (v2-h mp))))
175 (if (> (+ pref (l-width self)) (lr .og.)) ;; don't sail off to right of togl
176 (px-maintain-pr (lr .og.) #+hunh? (- (v2-h mp) 16))
177 pref)))))
178 (t (setf fixed nil))))))
179 :py (let (fixed)
180 (c? (bwhen (mp (mouse-pos .og.))
181 (cond
182 ((^visible)
183 .retog.
184 (or fixed (setf fixed
185 (min (- (lt .og.)(l-height self))
186 (+ 6 (py-maintain-pb (v2-v mp)))))))
187 (t (setf fixed nil)))))))

  ViewVC Help
Powered by ViewVC 1.1.5