blob: 461421b967d15c21a36569935826b48492ac8a87 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
;;; ---------------------------------------------------------------------------
;;; License: LGPL-2.1+ (See file 'Copyright' for details).
;;; ---------------------------------------------------------------------------
;;;
;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com)
;;; (c) copyright 2018-2020 Jan Moringen (jmoringe@techfak.uni-bielefeld.de)
;;;
;;; ---------------------------------------------------------------------------
;;;
;;; Utilities for text size-related tests.
;;;
(in-package #:clim-demo)
;;; State
(defclass state ()
((%text :initarg :text
:accessor text)
(%text-family :initarg :text-family
:accessor text-family)
(%text-face :initarg :text-face
:accessor text-face)
(%text-size :initarg :text-size
:accessor text-size*)
(%rectangle :initarg :rectangle
:type (member nil :text-size :text-bounding-rectangle)
:accessor rectangle)
(%hook :initarg :hook
:accessor hook
:initform nil))
(:default-initargs :text "(no text)"))
(defmethod maybe-run-hook ((state state))
(alexandria:when-let ((hook (hook state)))
(funcall hook state)))
(defmethod (setf text) :after (new-value (state state))
(maybe-run-hook state))
(defmethod (setf text-family) :after (new-value (state state))
(maybe-run-hook state))
(defmethod (setf text-face) :after (new-value (state state))
(maybe-run-hook state))
(defmethod (setf text-size*) :after (new-value (state state))
(maybe-run-hook state))
(defmethod (setf rectangle) :after (new-value (state state))
(maybe-run-hook state))
(defmethod text-style ((state state))
(make-text-style (text-family state) (text-face state) (text-size* state)))
;;; Canvas
(defclass canvas (basic-pane)
((%state :initarg :state
:reader state))
(:default-initargs
:background +white+))
(defmethod initialize-instance :after ((instance canvas) &key state)
(setf (hook state) (lambda (state)
(declare (ignore state))
(dispatch-repaint instance (sheet-region instance)))))
(defmethod resize-sheet :after ((sheet canvas) width height)
(dispatch-repaint sheet (sheet-region sheet)))
(defmethod handle-repaint ((sheet canvas) region)
(draw-text-size-info sheet (state sheet)))
(defun draw-text-size-info (stream state)
(let* ((medium (sheet-medium stream))
(region (let ((region (sheet-region stream)))
(if (not (region-equal region +everywhere+))
region
(make-rectangle* 0 0 800 600))))
(pane-width (rectangle-width region))
(pane-height (rectangle-height region))
(text (text state))
(style (text-style state))
(rectangle (rectangle state)))
(draw-design stream region :ink (clime:background stream))
(multiple-value-bind (width height final-x final-y baseline)
(text-size stream text :text-style style)
(let* ((x1 (/ (- pane-width width) 2))
(y1 (/ (- pane-height height) 2))
(ybase (+ y1 baseline))
(inks (coerce (make-contrasting-inks 8) 'list))
(legend-entries '())
(legend-text-style (make-text-style :sans-serif :roman :small)))
(labels ((draw-vdist (stream x y1 y2)
(draw-line* stream (- x 10) y1 (+ x 10) y1)
(draw-line* stream (- x 10) y2 (+ x 10) y2)
(draw-arrow* stream x y1 x y2))
(draw-hdist (stream y x1 x2)
(draw-line* stream x1 (- y 10) x1 (+ y 10))
(draw-line* stream x2 (- y 10) x2 (+ y 10))
(draw-arrow* stream x1 y x2 y))
(component (title thunk &rest args &key &allow-other-keys)
(let* ((ink (pop inks))
(drawing-options (list* :ink ink args)))
(push (cons title drawing-options) legend-entries)
(apply #'invoke-with-drawing-options
stream thunk drawing-options))))
(draw-text* stream
(format nil "fixed-width-p: ~(~A~)"
(handler-case
(text-style-fixed-width-p style medium)
(error (c)
c)))
2 pane-height :text-style legend-text-style)
(case rectangle
((:text-size :text-bounding-rectangle)
(component "Ascent"
(lambda (stream)
(let ((ascent (text-style-ascent style medium)))
(draw-vdist stream (- x1 20) ybase (- ybase ascent)))))
(component "Descend"
(lambda (stream)
(let ((descent (text-style-descent style medium)))
(draw-vdist stream (- x1 20) ybase (+ ybase descent)))))
(component "Height"
(lambda (stream)
(let ((height (text-style-height style medium)))
(draw-vdist stream (- x1 40) y1 (+ y1 height))))
:line-style (make-line-style :thickness 2))
(component "Average character width"
(lambda (stream)
(let ((width (text-style-width style medium)))
(draw-hdist stream (- y1 20) x1 (+ x1 width)))))
(component "Baseline"
(lambda (stream)
(draw-line* stream 0 ybase pane-width ybase)))))
(draw-text* stream text x1 ybase :text-style style)
(case rectangle
((:text-size)
(component "Text size (width/height)"
(lambda (stream)
(draw-rectangle*
stream x1 y1 (+ x1 width) (+ y1 height)
:filled nil)))
(component "Text size (final x/y)"
(lambda (stream)
(draw-line*
stream 0 (+ y1 final-y) pane-width (+ y1 final-y))
(draw-line*
stream (+ x1 final-x) 0 (+ x1 final-x) pane-height))))
((:text-bounding-rectangle)
(multiple-value-bind (left top right bottom)
(climb:text-bounding-rectangle* medium text :text-style style)
(component "Bounding rectangle"
(lambda (stream)
(draw-rectangle* stream
(+ x1 left) (+ y1 baseline top)
(+ x1 right) (+ y1 baseline bottom)
:filled nil)))))))
;; Draw a legend for all drawn components
(loop with line-height = (nth-value 1 (text-size
stream "dummy"
:text-style legend-text-style))
for (text . drawing-options) in (reverse legend-entries)
for y from (+ 2 line-height) by line-height
for y* = (+ 0.5 (round (- y (/ line-height 2))))
do (apply #'draw-line* stream 2 y* 35 y* drawing-options)
(draw-text* stream text 40 y :text-style legend-text-style))))))
|
