-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathfont-family.lisp
253 lines (206 loc) · 9.1 KB
/
font-family.lisp
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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
;;;-*- Mode:Common-Lisp; Package:PICTURES; Base:10 -*-
;;;
;;;
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 149149
;;; AUSTIN, TEXAS 78714-9149
;;;
;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Authors: Delmar Hager, James Dutton, Teri Crowe
;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke
(in-package "PICTURES")
;font families utilites
(DEFPARAMETER default-family-name "-adobe-helvetica-medium-r-normal-*")
(DEFCONSTANT *minimum-font-attributes-in-a-name* 1)
(DEFMACRO font-size (font)
`(+ (font-ascent ,font)(font-descent ,font)))
(DEFMACRO x11-font-string-p (font-name)
`(AND (STRINGP ,font-name)
(> (COUNT #\- ,font-name) minimum-font-attributes-in-a-name))
)
(defclass font-family ()
(
(family-name :type string
:accessor family-name
:initarg :family-name
:documentation "The name for a family of fonts ")
(family-members :type list
:initarg :family-members
:documentation "An assoc list of the member fonts and their sizes for a font-family")
)
)
(DEFMETHOD print-object ((font font) stream )
(FORMAT stream "~a" (font-name font)))
(DEFMACRO x11-font-sizes (font-string display)
`(MAPCAR #'(lambda (font-name) (READ-FROM-STRING (font-name-attribute font-name :size :size)))
(list-font-names ,display (CONCATENATE 'string ,font-string "*" )))
)
(DEFUN add-size (name size)
(IF (x11-font-string-p name)
(CONCATENATE 'string "-" (font-name-attribute name :company :blank)
(FORMAT nil "-~A" size) "-" (OR (font-name-attribute :resolution :rest) "*"))
(CONCATENATE 'string name size)))
(defmacro font-objects (members display)
"determine if members is nil, a string or a list of (font-name size) and return nil or a list of (font-name size)"
`(COND
((AND ,members (LISTP (FIRST ,members)))
(MAPCAR #'(lambda (font-list) (LIST (open-font ,display (CONCATENATE 'string (FIRST font-list) "*"))
(SECOND font-list))) ,members))
((AND (STRINGP (FIRST ,members)) (x11-font-string-p (FIRST ,members))(EQL (LENGTH ,members) 1))
(mapcar #'(lambda (size) (LIST
(open-font display (add-size (FIRST ,members) size)) size))
(SORT (x11-font-sizes (first ,members) ,display) '<)))
((STRINGP (FIRST ,members))
(get-size-font-pairs (mapcar #'(lambda (string) (open-font display string)) (list-ft-names ,members ,display)))))
)
(DEFUN list-ft-names (names display &optional font-names)
(DOLIST (name names)
(IF (x11-font-string-p name)
(SETF font-names (APPEND font-names (list-font-names display (CONCATENATE 'string name "*"))))
(SETF font-names (APPEND font-names (LIST name)))))
font-names)
(DEFUN get-size-font-pairs (font-list)
"given a font-list sort it according to font size and return a list of '(fonts size)"
(LET* ((font-size-pairs (MAPCAR #'(lambda (font) (LIST
(IF (x11-font-string-p (font-name font))
(READ-FROM-STRING (font-name-attribute
(font-name font) :size :size))
(font-size font))
font)) font-list))
(sorted-sizes (REMOVE-DUPLICATES
(SORT (MAPCAR #'(lambda (pairs) (FIRST pairs)) font-size-pairs) #'<))))
(MAPCAR #'(lambda (size) (NREVERSE (ASSOC size font-size-pairs))) sorted-sizes)))
(DEFUN make-font-family (family-name display &rest members)
(DECLARE (LIST members))
(funcall #'make-instance 'font-family
:display display
:family-name family-name
:family-members
(OR
(font-objects members display)
(IF (x11-font-string-p family-name)
(mapcar #'(lambda (x) (LIST
(open-font display (add-size family-name x)) x))
(SORT (x11-font-sizes family-name display) '<))
(mapcar #'(lambda (x) (LIST
(open-font display (add-size default-family-name x)) x))
(SORT (x11-font-sizes default-family-name display) '<))))))
(DEFMETHOD initialize-instance :around ((font-family font-family) &key family-name display)
(DECLARE (IGNORE members))
(LET ((font-families (GETF (display-plist display) 'font-families)))
(SETF font-families
(REMOVE (ASSOC family-name font-families :test #'STRING-EQUAL)
font-families :test #'EQUAL))
(SETF (GETF (display-plist display) 'font-families)
(APPEND font-families (LIST (LIST family-name (call-next-method)))))))
(DEFUN find-font-family (family-name display)
"Returns the font-family of the FAMILY-NAME for the DISPLAY"
(SECOND (ASSOC family-name (GETF (display-plist display) 'font-families) :test #'STRING-EQUAL ))
)
(DEFSETF find-font-family (family-name display) (font-family)
`(LET ((font-families (GETF (display-plist ,display) 'font-families)))
(SETF font-families
(REMOVE (ASSOC ,family-name font-families :test #'STRING-EQUAL)
font-families :test #'EQUAL))
(SETF (GETF (display-plist ,display) 'font-families)
(APPEND font-families (LIST (LIST ,family-name ,font-family))))
,font-family))
(DEFMACRO the-font-size (MEMBER)
`(SECOND ,member))
(DEFMACRO the-font (MEMBER)
`(FIRST ,member))
(DEFMETHOD find-font ((family font-family) size)
(with-slots (family-members) family
(WHEN family-members
(IF (< size (the-font-size (FIRST family-members)))
(the-font (FIRST family-members))
(DO* ((font-pair (FIRST family-members) next-pair)
(font-size (the-font-size font-pair) next-font-size)
(next-font-pairs (REST family-members) (REST next-font-pairs))
(next-pair (FIRST next-font-pairs) (FIRST next-font-pairs))
(next-font-size (the-font-size next-pair) (the-font-size next-pair))
)
((not next-pair ) (the-font font-pair))
(WHEN (= font-size size) (RETURN (the-font font-pair)))
(WHEN (< font-size size next-font-size)
(RETURN (the-font font-pair)
)))))))
(DEFMETHOD (SETF find-font ) ( font (family font-family) size )
(with-slots (family-members) family
(WHEN (< size (SECOND (FIRST family-members))) (FIRST (FIRST family-members)))
(DO* ((pairs 1 (1+ pairs))
(font-pair (FIRST family-members) next-pair)
(font-size (SECOND font-pair) next-font-size)
(next-font-pairs (CDR family-members) (CDR next-font-pairs))
(next-pair (FIRST next-font-pairs) (FIRST next-font-pairs))
(next-font-size (SECOND next-pair) (SECOND next-pair))
)
((NOT next-pair )
(IF (= font-size size) (SETF (FIRST font-pair) font)
(SETF family-members (APPEND family-members (LIST (LIST font size)))))
(RETURN font))
(WHEN (= font-size size) (SETF (FIRST font-pair) font) (RETURN font))
(WHEN (< font-size size next-font-size)
(SETF family-members (APPEND (BUTLAST family-members (- (LENGTH family-members) pairs))
(LIST (LIST font size))
(NTHCDR pairs family-members)))
(RETURN font)))))
(DEFMETHOD font-family-members ((family font-family) display)
(DECLARE (IGNORE display))
(slot-value family 'family-members)
)
(DEFMETHOD (SETF font-family-members) ( members (family font-family) display)
(IF members
(SETF (slot-value family 'family-members) (font-objects members display))
(ERROR "~%the value for members is ~a ~%" members)))
;get the attributes from the X11 font name
(DEFUN dash-positions (STRING &optional position-list)
(IF (> (OR (FIRST (LAST position-list)) 0) (LENGTH string))
(BUTLAST position-list)
(dash-positions string (APPEND position-list
(LIST (OR
(POSITION #\- string
:start (1+ (OR (FIRST (LAST position-list)) -1)))
+large-number+))))))
(DEFUN font-name-attribute (name attribute &optional (name-range nil))
"Parse the X11 font NAME string and for a ATTRIBUTE and return the string representing the ATTRIBUTE.
ATTRIBUTE is (member :size :company :weight :blank :name :resolution :end)"
(WHEN (x11-font-string-p name)
(flet ((elt-safe
(sequence index)
(when (< index (length sequence))
(elt sequence index))))
(LET* ((dash-positions (dash-positions name))
(attribute-position
(CASE attribute
(:size (ELT-SAFE dash-positions 6))
(:company (ELT-SAFE dash-positions 0))
(:weight (ELT-SAFE dash-positions 2))
(:blank (ELT-SAFE dash-positions 5))
(:name (ELT-SAFE dash-positions 1))
(:resolution (ELT-SAFE dash-positions 7))
))
(name-range-position
(CASE name-range
(:size (ELT-SAFE dash-positions 7))
(:company (ELT-SAFE dash-positions 1))
(:weight (ELT-SAFE dash-positions 3))
(:blank (ELT-SAFE dash-positions 6))
(:name (ELT-SAFE dash-positions 2))
(:resolution (ELT-SAFE dash-positions 8))
(:end (ELT-SAFE dash-positions 14))
(:rest (LENGTH name))
)))
(SUBSEQ name (1+ (OR attribute-position 0))
name-range-position )
))))