Coverage report: /home/ellis/comp/core/lib/dat/ttf.lisp

Kind	Covered	All	%
expression	0	3072	0.0
branch	0	206	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; ttf.lisp --- TrueType Fonts

2

3

;; Access TrueType font metrics and outlines from Common Lisp

4

5

;; Written by Zach Beane <xach@xach.com>

6

7

;; Copyright (c) 2006 Zachary Beane, All Rights Reserved

8

;;

9

;; Redistribution and use in source and binary forms, with or without

10

;; modification, are permitted provided that the following conditions

11

;; are met:

12

;;

13

;; * Redistributions of source code must retain the above copyright

14

;; notice, this list of conditions and the following disclaimer.

15

;;

16

;; * Redistributions in binary form must reproduce the above

17

;; copyright notice, this list of conditions and the following

18

;; disclaimer in the documentation and/or other materials

19

;; provided with the distribution.

20

;;

21

;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED

22

;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

23

;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE

24

;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY

25

;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

26

;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE

27

;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS

28

;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

29

;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

30

;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

31

;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

32

33

;;; Code:

34

(in-package :dat/ttf)

35

;;; Utils

36

(defun read-uint32 (stream)

37

(loop repeat 4

38

for value = (read-byte stream)

39

then (logior (ash value 8) (read-byte stream))

40

finally (return value)))

41

42

(defun read-uint16 (stream)

43

(loop repeat 2

44

for value = (read-byte stream)

45

then (logior (ash value 8) (read-byte stream))

46

finally (return value)))

47

48

(defun read-uint8 (stream)

49

(read-byte stream))

50

51

(defun read-int8 (stream)

52

(let ((result (read-byte stream)))

53

(if (logbitp 7 result)

54

(1- (- (logandc2 #xFF result)))

55

result)))

56

57

(defun read-int16 (stream)

58

(let ((result (read-uint16 stream)))

59

(if (logbitp 15 result)

60

(1- (- (logandc2 #xFFFF result)))

61

result)))

62

63

(defun read-fixed (stream)

64

(read-uint32 stream))

65

66

(defun read-fword (stream)

67

(read-int16 stream))

68

69

(defun read-ufword (stream)

70

(read-uint16 stream))

71

72

(defun read-fixed2.14 (stream)

73

(let ((value (read-uint16 stream)))

74

(let ((integer (ash value -14))

75

(fraction (logand #x3FFF value)))

76

(when (logbitp 1 integer)

77

(setf integer (1- (- (logandc2 #b11 integer)))))

78

(+ integer (float (/ fraction #x4000))))))

79

80

(defun read-pstring (stream)

81

"Read a Pascal-style length-prefixed string."

82

(let* ((length (read-uint8 stream))

83

(buf (make-array length :element-type '(unsigned-byte 8)))

84

(string (make-string length)))

85

(read-sequence buf stream)

86

;; The following could be (map 'string #'code-char buf), but that

87

;; form benchmarked poorly

88

(dotimes (i length string)

89

(setf (schar string i) (code-char (aref buf i))))))

90

91

(defun advance-file-position (stream n)

92

"Move the file position of STREAM ahead by N bytes."

93

(let ((pos (file-position stream)))

94

(file-position stream (+ pos n))))

95

96

(defun bounded-aref (vector index)

97

"Some TrueType data vectors are truncated, and any references beyond

98

the end of the vector should be treated as a reference to the last

99

element in the vector."

100

(aref vector (min (1- (length vector)) index)))

101

102

(defun (setf bounded-aref) (new-value vector index)

103

(setf (aref vector (min (1- (length vector)) index)) new-value))

104

105

;;; Conditions

106

(define-condition regrettable-value (error)

107

((actual-value

108

:initarg :actual-value

109

:accessor actual-value)

110

(expected-values

111

:initarg :expected-values

112

:accessor expected-values)

113

(description

114

:initarg :description

115

:initform nil

116

:accessor description)

117

(location

118

:initarg :location

119

:initform nil

120

:accessor location))

121

(:report

122

(lambda (c s)

123

(format s "~:[Regrettable~;~:*~A~] value~:[~;~:* in ~A~]: ~

124

~A (expected ~{~A~^ or ~})"

125

(description c)

126

(location c)

127

(actual-value c)

128

(expected-values c)))))

129

130

(define-condition regrettable-hex-value (regrettable-value)

131

((size

132

:initarg :size

133

:initform 8

134

:accessor size)

135

(actual-value

136

:reader %actual-value)

137

(expected-values

138

:reader %expected-values)))

139

140

(defmethod actual-value ((c regrettable-hex-value))

141

(format nil "#x~v,'0X" (size c) (%actual-value c)))

142

143

(defmethod expected-values ((c regrettable-hex-value))

144

(mapcar (lambda (v)

145

(format nil "#x~v,'0X" (size c) v))

146

(%expected-values c)))

147

148

(define-condition bad-magic (regrettable-hex-value)

149

((description :initform "Bad magic")))

150

151

(define-condition unsupported-version (regrettable-hex-value)

152

((description :initform "Unsupported version")))

153

154

(define-condition unsupported-format (regrettable-hex-value)

155

((description :initform "Unsupported format")))

156

157

(define-condition unsupported-value (regrettable-value)

158

((description :initform "Unsupported")))

159

160

(defun check-version (location actual &rest expected)

161

(or (member actual expected :test #'=)

162

(error 'unsupported-version

163

:location location

164

:actual-value actual

165

:expected-values expected)))

166

167

;;; Bounding Box

168

(defgeneric bounding-box (object))

169

170

(macrolet ((bbox-accessor (name index)

171

`(progn

172

(defgeneric ,name (object)

173

(:method (object)

174

(aref (bounding-box object) ,index)))

175

(defgeneric (setf ,name) (new-value object)

176

(:method (new-value object)

177

(setf (aref (bounding-box object) ,index) new-value))))))

178

(bbox-accessor bbox-xmin 0)

179

(bbox-accessor bbox-ymin 1)

180

(bbox-accessor bbox-xmax 2)

181

(bbox-accessor bbox-ymax 3))

182

183

(defmethod bounding-box ((object array))

184

object)

185

186

;;; Font Loader

187

(defclass font-loader ()

188

((tables :initform (make-hash-table) :reader tables)

189

(input-stream :initarg :input-stream :accessor input-stream

190

:documentation "The stream from which things are loaded.")

191

(table-count :initarg :table-count :reader table-count)

192

;; from the 'head' table

193

(units/em :accessor units/em)

194

(bounding-box :accessor bounding-box)

195

(loca-offset-format :accessor loca-offset-format)

196

;; from the 'loca' table

197

(glyph-locations :accessor glyph-locations)

198

;; from the 'cmap' table

199

(character-map :accessor character-map)

200

(inverse-character-map :accessor inverse-character-map)

201

;; from the 'maxp' table

202

(glyph-count :accessor glyph-count)

203

;; from the 'hhea' table

204

(ascender :accessor ascender)

205

(descender :accessor descender)

206

(line-gap :accessor line-gap)

207

(max-width :accessor max-width)

208

;; from the 'hmtx' table

209

(advance-widths :accessor advance-widths)

210

(left-side-bearings :accessor left-side-bearings)

211

;; from the 'vhea' table

212

(vhea-missing-p :initform nil :accessor vhea-missing-p)

213

(vascender :accessor vascender)

214

(vdescender :accessor vdescender)

215

;; from 'vhea' and 'vmtx' tables

216

(vmtx-missing-p :initform nil :accessor vmtx-missing-p)

217

(advance-heights :accessor advance-heights)

218

(top-side-bearings :accessor top-side-bearings)

219

;; from the 'kern' table

220

(kerning-table :initform (make-hash-table) :accessor kerning-table)

221

;; from the 'name' table

222

(name-entries :initform nil :accessor name-entries)

223

;; from the 'post' table

224

(italic-angle :accessor italic-angle :initform 0)

225

(fixed-pitch-p :accessor fixed-pitch-p :initform nil)

226

(underline-position :accessor underline-position :initform 0)

227

(underline-thickness :accessor underline-thickness :initform 0)

228

(postscript-glyph-names :accessor postscript-glyph-names)

229

;; misc

230

(glyph-cache :accessor glyph-cache)

231

;; # of fonts in collection, if loaded from a ttc file

232

(collection-font-count :reader collection-font-count :initform nil

233

:initarg :collection-font-cont)

234

;; index of font in collection, if loaded from a ttc file

235

(collection-font-index :reader collection-font-index :initform nil

236

:initarg :collection-font-index)))

237

238

(defclass table-info ()

239

((name :initarg :name :reader name)

240

(offset :initarg :offset :reader offset)

241

(size :initarg :size :reader size)))

242

243

(defmethod print-object ((object table-info) stream)

244

(print-unreadable-object (object stream :type t)

245

(format stream "\"~A\"" (name object))))

246

247

;;; tag integers to strings and back

248

(defun number->tag (number)

249

"Convert the 32-bit NUMBER to a string of four characters based on

250

the CODE-CHAR of each octet in the number."

251

(let ((tag (make-string 4)))

252

(loop for i below 4

253

for offset from 24 downto 0 by 8

254

do (setf (schar tag i)

255

(code-char (ldb (byte 8 offset) number))))

256

tag))

257

258

(defun tag->number (tag)

259

"Convert the four-character string TAG to a 32-bit number based on

260

the CHAR-CODE of each character."

261

(declare (simple-string tag))

262

(loop for char across tag

263

for offset from 24 downto 0 by 8

264

summing (ash (char-code char) offset)))

265

266

;;; Getting table info out of the loader

267

(defmethod table-info ((tag string) (font-loader font-loader))

268

(gethash (tag->number tag) (tables font-loader)))

269

270

(defmethod table-exists-p (tag font-loader)

271

(nth-value 1 (table-info tag font-loader)))

272

273

(defmethod table-position ((tag string) (font-loader font-loader))

274

"Return the byte position in the font-loader's stream for the table

275

named by TAG."

276

(let ((table-info (table-info tag font-loader)))

277

(if table-info

278

(offset table-info)

279

(error "No such table -- ~A" tag))))

280

281

(defmethod table-size ((tag string) (font-loader font-loader))

282

(let ((table-info (table-info tag font-loader)))

283

(if table-info

284

(size table-info)

285

(error "No such table -- ~A" tag))))

286

287

(defmethod seek-to-table ((tag string) (font-loader font-loader))

288

"Move FONT-LOADER's input stream to the start of the table named by TAG."

289

(let ((table-info (table-info tag font-loader)))

290

(if table-info

291

(seek-to-table table-info font-loader)

292

(error "No such table -- ~A" tag))))

293

294

(defmethod seek-to-table ((table table-info) (font-loader font-loader))

295

"Move FONT-LOADER's input stream to the start of TABLE."

296

(file-position (input-stream font-loader) (offset table)))

297

298

;;; maxp

299

;; Loading data from the "maxp" table.

300

301

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/maxp

302

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6maxp.html

303

304

(defmethod load-maxp-info ((font-loader font-loader))

305

(seek-to-table "maxp" font-loader)

306

(with-slots (input-stream glyph-count) font-loader

307

(let ((version (read-uint32 input-stream)))

308

(check-version "\"maxp\" table" version #x00010000)

309

(setf glyph-count (read-uint16 input-stream)))))

310

311

;;; head

312

;; Loading data from the "head" table.

313

314

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/head

315

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6head.html

316

317

(defmethod load-head-info ((font-loader font-loader))

318

(seek-to-table "head" font-loader)

319

(with-slots (input-stream units/em bounding-box loca-offset-format)

320

font-loader

321

(flet ((skip-bytes (count)

322

(file-position input-stream (+ count

323

                                             (file-position input-stream)))))

324

(let ((version (read-uint32 input-stream)))

325

(check-version "\"head\" table" version #x00010000))

326

;; skip fontRevsion and checkSumAdjustment (both uint32)

327

(skip-bytes 8)

328

;; check the magicNumber

329

(let ((magic-number (read-uint32 input-stream)))

330

(when (/= magic-number #x5F0F3CF5)

331

(error 'bad-magic

332

:location "\"head\" table"

333

:expected-values (list #x5F0F3CF5)

334

:actual-value magic-number)))

335

;; skip flags

336

(skip-bytes 2)

337

(setf units/em (read-uint16 input-stream))

338

;; skip created and modified dates

339

(skip-bytes 16)

340

(setf bounding-box (vector (read-int16 input-stream)

341

(read-int16 input-stream)

342

(read-int16 input-stream)

343

(read-int16 input-stream)))

344

;; skip macStyle, lowestRecPPEM, fontDirectionHint

345

(skip-bytes 6)

346

;; set the loca-offset-format

347

(if (zerop (read-int16 input-stream))

348

(setf loca-offset-format :short)

349

(setf loca-offset-format :long)))))

350

351

;;; kern

352

;; "kern" table functions

353

354

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/kern

355

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6kern.html

356

(defun load-kerning-format-0 (table stream)

357

"Return a hash table keyed on a UINT32 key that represents the glyph

358

index in the left and right halves with a value of the kerning

359

distance between the pair."

360

(let ((pair-count (read-uint16 stream))

361

(search-range (read-uint16 stream))

362

(entry-selector (read-uint16 stream))

363

(range-shift (read-uint16 stream))

364

(bytes-read 8))

365

(declare (ignore search-range entry-selector range-shift))

366

(dotimes (i pair-count)

367

(let ((key (read-uint32 stream))

368

(value (read-int16 stream)))

369

;; apple specifies a terminating entry, ignore it

370

(unless (and (= key #xffffffff) (= value 0))

371

(setf (gethash key table) value))

372

(incf bytes-read 6)))

373

bytes-read))

374

375

(defun parse-offset-table (buffer start)

376

(let ((first-glyph (aref buffer start))

377

(glyph-count (aref buffer (1+ start)))

378

(offsets (make-hash-table)))

379

(loop for i from (+ start 2)

380

for g from first-glyph

381

repeat glyph-count

382

collect (setf (gethash g offsets) (aref buffer i)))

383

offsets))

384

385

(defun load-kerning-format-2 (table stream size)

386

"Return a hash table keyed on a UINT32 key that represents the glyph

387

index in the left and right halves with a value of the kerning

388

distance between the pair."

389

(let* ((buffer (coerce (loop repeat (/ size 2)

390

collect (read-uint16 stream))

391

'(simple-array (unsigned-byte) 1)))

392

(row-width (aref buffer 0))

393

(left-offset-table (aref buffer 1))

394

(right-offset-table (aref buffer 2))

395

(array-offset (aref buffer 3))

396

(left (parse-offset-table buffer (- (/ left-offset-table 2) 4)))

397

(right (parse-offset-table buffer (- (/ right-offset-table 2) 4))))

398

(declare (ignorable row-width array-offset))

399

(flet ((s16 (x)

400

(if (logbitp 15 x)

401

(1- (- (logandc2 #xFFFF x)))

402

x)))

403

(maphash (lambda (lk lv)

404

(maphash (lambda (rk rv)

405

(let ((key (logior (ash lk 16) rk))

406

(value (s16 (aref buffer

407

                                                     (- (/ (+ lv rv) 2) 4)))))

408

(unless (zerop value)

409

(setf (gethash key table) value))))

410

right))

411

left))

412

size))

413

414

(defmethod load-kerning-subtable ((font-loader font-loader) format size)

415

(when (/= format 0 1 2)

416

(error 'unsupported-format

417

:description "kerning subtable"

418

:size 1

419

:expected-values (list 0 1 2)

420

:actual-value format))

421

(case format

422

(0

423

(load-kerning-format-0 (kerning-table font-loader)

424

(input-stream font-loader)))

425

(1

426

;; state table for contextual kerning, ignored for now

427

(advance-file-position (input-stream font-loader) (- size 8))

428

(- size 8))

429

(2

430

(load-kerning-format-2 (kerning-table font-loader)

431

(input-stream font-loader)

432

size))))

433

434

(defmethod load-kern-info ((font-loader font-loader))

435

(when (table-exists-p "kern" font-loader)

436

(seek-to-table "kern" font-loader)

437

(let* ((stream (input-stream font-loader))

438

(maybe-version (read-uint16 stream))

439

(maybe-table-count (read-uint16 stream))

440

(version 0)

441

(table-count 0)

442

(apple-p nil))

443

;; These shenanegins are because Apple documents one style of

444

;; kern table and Microsoft documents another. This code

445

;; tries to support both.

446

;; See:

447

;; https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6kern.html

448

;; https://learn.microsoft.com/en-us/typography/opentype/spec/kern

449

(if (zerop maybe-version)

450

(setf version maybe-version

451

table-count maybe-table-count)

452

(setf version (logand (ash maybe-version 16) maybe-table-count)

453

table-count (read-uint32 stream)

454

apple-p t))

455

(check-version "\"kern\" table" version 0)

456

(dotimes (i table-count)

457

(let ((version (read-uint16 stream))

458

(length (read-uint16 stream))

459

(coverage-flags (read-uint8 stream))

460

(format (read-uint8 stream)))

461

(declare (ignorable version))

462

(case coverage-flags

463

;; only read horizontal kerning, since storing others in

464

;; same array would be confusing and vertical layouts

465

;; don't seem to be supported currently

466

(0

467

(when apple-p

468

(read-uint16 stream)) ; read and discard tuple-index

469

470

(let ((bytes-read (+ (load-kerning-subtable font-loader format

471

                                                          length)

472

(if apple-p 8 6))))

473

(advance-file-position stream (- length bytes-read))))

474

;; ignore other known types of kerning

475

((#x8000 ;; vertical

476

#x4000 ;; cross stream

477

#x2000) ;; variation

478

(advance-file-position stream (- length 6)))

479

;; otherwise error

480

(otherwise

481

(error 'unsupported-format

482

:description "kerning subtable coverage"

483

:size 2

484

:expected-values (list 0 #x2000 #x4000 #x8000)

485

:actual-value coverage-flags))))))))

486

487

(defmethod all-kerning-pairs ((font-loader font-loader))

488

(let ((pairs nil))

489

(maphash (lambda (k v)

490

(let* ((left-index (ldb (byte 16 16) k))

491

(right-index (ldb (byte 16 0) k))

492

(left (index-glyph left-index font-loader))

493

(right (index-glyph right-index font-loader)))

494

(push (list left right v) pairs)))

495

(kerning-table font-loader))

496

pairs))

497

498

;;; loca

499

;; Loading data from the "loca" table.

500

501

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/loca

502

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6loca.html

503

(defmethod load-loca-info ((font-loader font-loader))

504

(seek-to-table "loca" font-loader)

505

(with-slots (input-stream glyph-locations glyph-count loca-offset-format)

506

font-loader

507

(setf glyph-locations (make-array (1+ glyph-count)))

508

(dotimes (i (1+ glyph-count))

509

(setf (svref glyph-locations i)

510

(if (eql loca-offset-format :short)

511

(* (read-uint16 input-stream) 2)

512

(read-uint32 input-stream))))))

513

514

(defmethod glyph-location (index (font-loader font-loader))

515

(aref (glyph-locations font-loader) index))

516

517

(defmethod glyph-length (index (font-loader font-loader))

518

(with-slots (glyph-locations)

519

font-loader

520

(- (aref glyph-locations (1+ index))

521

(aref glyph-locations index))))

522

523

;;; name

524

;; Loading data from the TrueType "name" table.

525

526

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/name

527

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6name.html

528

(defvar *name-identifiers*

529

#(:copyright-notice

530

:font-family

531

:font-subfamily

532

:unique-subfamily

533

:full-name

534

:name-table-version

535

:postscript-name

536

:trademark-notice

537

:manufacturer-name

538

:designer

539

:description

540

:vendor-url

541

:designer-url

542

:license-description

543

:licence-info-url

544

:reserved

545

:preferred-family

546

:preferred-subfamily

547

:compatible-full

548

:sample-text))

549

550

(defvar *platform-identifiers*

551

#(:unicode

552

:macintosh

553

:iso

554

:microsoft

555

:custom))

556

557

(defvar *unicode-encoding-ids*

558

#(:unicode-1.0

559

:unicode-1.1

560

:iso-10646\:1993

561

:unicode>=2.0-bmp-only

562

:unicode>=2.0-full-repertoire))

563

564

(defvar *microsoft-encoding-ids*

565

#(:symbol

566

:unicode

567

:shiftjis

568

:prc

569

:big5

570

:wansung

571

:johab

572

:7-reserved

573

:8-reserved

574

:9-reserved

575

:ucs-4))

576

577

(defvar *macintosh-encoding-ids*

578

#(:roman

579

:japanese

580

:chinese-traditional

581

:korean

582

:arabic

583

:hebrew

584

:greek

585

:russian

586

:RSymbol

587

:devanagari

588

:gurmukhi

589

:gujarati

590

:oriya

591

:bengali

592

:tamil

593

:telugu

594

:kennada

595

:malayam

596

:sinhalese

597

:burmese

598

:khmer

599

:thai

600

:laotian

601

:georgian

602

:armenian

603

:chinese-simplified

604

:tibetan

605

:mongolian

606

:geez

607

:slavic

608

:vietnamese

609

:sindhi

610

:uninterpreted))

611

612

(defvar *iso-encoding-ids*

613

#(:7-bit-ascii

614

:iso-10646

615

:iso-8859-1))

616

617

(defparameter *encoding-tables*

618

(vector *unicode-encoding-ids*

619

*macintosh-encoding-ids*

620

*iso-encoding-ids*

621

*microsoft-encoding-ids*

622

nil))

623

624

(defun encoding-id-name (platform-id encoding-id)

625

(if (and (array-in-bounds-p *encoding-tables* platform-id)

626

(aref *encoding-tables* platform-id)

627

(array-in-bounds-p (aref *encoding-tables* platform-id) encoding-id))

628

(aref (aref *encoding-tables* platform-id) encoding-id)

629

encoding-id))

630

631

(defun platform-id-name (platform-id)

632

(if (array-in-bounds-p *platform-identifiers* platform-id)

633

(aref *platform-identifiers* platform-id)

634

platform-id))

635

636

(defparameter *macroman-translation-table*

637

#(#x00 #x00

638

#x01 #x01

639

#x02 #x02

640

#x03 #x03

641

#x04 #x04

642

#x05 #x05

643

#x06 #x06

644

#x07 #x07

645

#x08 #x08

646

#x09 #x09

647

#x0A #x0A

648

#x0B #x0B

649

#x0C #x0C

650

#x0D #x0D

651

#x0E #x0E

652

#x0F #x0F

653

#x10 #x10

654

#x11 #x11

655

#x12 #x12

656

#x13 #x13

657

#x14 #x14

658

#x15 #x15

659

#x16 #x16

660

#x17 #x17

661

#x18 #x18

662

#x19 #x19

663

#x1A #x1A

664

#x1B #x1B

665

#x1C #x1C

666

#x1D #x1D

667

#x1E #x1E

668

#x1F #x1F

669

#x20 #x20

670

#x21 #x21

671

#x22 #x22

672

#x23 #x23

673

#x24 #x24

674

#x25 #x25

675

#x26 #x26

676

#x27 #x27

677

#x28 #x28

678

#x29 #x29

679

#x2A #x2A

680

#x2B #x2B

681

#x2C #x2C

682

#x2D #x2D

683

#x2E #x2E

684

#x2F #x2F

685

#x30 #x30

686

#x31 #x31

687

#x32 #x32

688

#x33 #x33

689

#x34 #x34

690

#x35 #x35

691

#x36 #x36

692

#x37 #x37

693

#x38 #x38

694

#x39 #x39

695

#x3A #x3A

696

#x3B #x3B

697

#x3C #x3C

698

#x3D #x3D

699

#x3E #x3E

700

#x3F #x3F

701

#x40 #x40

702

#x41 #x41

703

#x42 #x42

704

#x43 #x43

705

#x44 #x44

706

#x45 #x45

707

#x46 #x46

708

#x47 #x47

709

#x48 #x48

710

#x49 #x49

711

#x4A #x4A

712

#x4B #x4B

713

#x4C #x4C

714

#x4D #x4D

715

#x4E #x4E

716

#x4F #x4F

717

#x50 #x50

718

#x51 #x51

719

#x52 #x52

720

#x53 #x53

721

#x54 #x54

722

#x55 #x55

723

#x56 #x56

724

#x57 #x57

725

#x58 #x58

726

#x59 #x59

727

#x5A #x5A

728

#x5B #x5B

729

#x5C #x5C

730

#x5D #x5D

731

#x5E #x5E

732

#x5F #x5F

733

#x60 #x60

734

#x61 #x61

735

#x62 #x62

736

#x63 #x63

737

#x64 #x64

738

#x65 #x65

739

#x66 #x66

740

#x67 #x67

741

#x68 #x68

742

#x69 #x69

743

#x6A #x6A

744

#x6B #x6B

745

#x6C #x6C

746

#x6D #x6D

747

#x6E #x6E

748

#x6F #x6F

749

#x70 #x70

750

#x71 #x71

751

#x72 #x72

752

#x73 #x73

753

#x74 #x74

754

#x75 #x75

755

#x76 #x76

756

#x77 #x77

757

#x78 #x78

758

#x79 #x79

759

#x7A #x7A

760

#x7B #x7B

761

#x7C #x7C

762

#x7D #x7D

763

#x7E #x7E

764

#x7F #x7F

765

#x80 #x00C4

766

#x81 #x00C5

767

#x82 #x00C7

768

#x83 #x00C9

769

#x84 #x00D1

770

#x85 #x00D6

771

#x86 #x00DC

772

#x87 #x00E1

773

#x88 #x00E0

774

#x89 #x00E2

775

#x8A #x00E4

776

#x8B #x00E3

777

#x8C #x00E5

778

#x8D #x00E7

779

#x8E #x00E9

780

#x8F #x00E8

781

#x90 #x00EA

782

#x91 #x00EB

783

#x92 #x00ED

784

#x93 #x00EC

785

#x94 #x00EE

786

#x95 #x00EF

787

#x96 #x00F1

788

#x97 #x00F3

789

#x98 #x00F2

790

#x99 #x00F4

791

#x9A #x00F6

792

#x9B #x00F5

793

#x9C #x00FA

794

#x9D #x00F9

795

#x9E #x00FB

796

#x9F #x00FC

797

#xA0 #x2020

798

#xA1 #x00B0

799

#xA2 #x00A2

800

#xA3 #x00A3

801

#xA4 #x00A7

802

#xA5 #x2022

803

#xA6 #x00B6

804

#xA7 #x00DF

805

#xA8 #x00AE

806

#xA9 #x00A9

807

#xAA #x2122

808

#xAB #x00B4

809

#xAC #x00A8

810

#xAD #x2260

811

#xAE #x00C6

812

#xAF #x00D8

813

#xB0 #x221E

814

#xB1 #x00B1

815

#xB2 #x2264

816

#xB3 #x2265

817

#xB4 #x00A5

818

#xB5 #x00B5

819

#xB6 #x2202

820

#xB7 #x2211

821

#xB8 #x220F

822

#xB9 #x03C0

823

#xBA #x222B

824

#xBB #x00AA

825

#xBC #x00BA

826

#xBD #x03A9

827

#xBE #x00E6

828

#xBF #x00F8

829

#xC0 #x00BF

830

#xC1 #x00A1

831

#xC2 #x00AC

832

#xC3 #x221A

833

#xC4 #x0192

834

#xC5 #x2248

835

#xC6 #x2206

836

#xC7 #x00AB

837

#xC8 #x00BB

838

#xC9 #x2026

839

#xCA #x00A0

840

#xCB #x00C0

841

#xCC #x00C3

842

#xCD #x00D5

843

#xCE #x0152

844

#xCF #x0153

845

#xD0 #x2103

846

#xD1 #x2014

847

#xD2 #x201C

848

#xD3 #x201D

849

#xD4 #x2018

850

#xD5 #x2019

851

#xD6 #x00F7

852

#xD7 #x25CA

853

#xD8 #x00FF

854

#xD9 #x0178

855

#xDA #x2044

856

#xDB #x20AC

857

#xDC #x2039

858

#xDD #x203A

859

#xDE #xFB01

860

#xDF #xFB02

861

#xE0 #x2021

862

#xE1 #x00B7

863

#xE2 #x201A

864

#xE3 #x201E

865

#xE4 #x2030

866

#xE5 #x00C2

867

#xE6 #x00CA

868

#xE7 #x00C1

869

#xE8 #x00CB

870

#xE9 #x00C8

871

#xEA #x00CD

872

#xEB #x00CE

873

#xEC #x00CF

874

#xED #x00CC

875

#xEE #x00D3

876

#xEF #x00D4

877

#xF0 #xF8FF

878

#xF1 #x00D2

879

#xF2 #x00DA

880

#xF3 #x00DB

881

#xF4 #x00D9

882

#xF5 #x0131

883

#xF6 #x02C6

884

#xF7 #x02DC

885

#xF8 #x00AF

886

#xF9 #x02D8

887

#xFA #x02D9

888

#xFB #x02DA

889

#xFC #x00B8

890

#xFD #x02DD

891

#xFE #x02DB

892

#xFF #x02C7))

893

894

(defconstant +unicode-platform-id+ 0)

895

(defconstant +macintosh-platform-id+ 1)

896

(defconstant +iso-platform-id+ 2)

897

(defconstant +microsoft-platform-id+ 3)

898

(defconstant +custom-platform-id+ 4)

899

900

(defconstant +unicode-2.0-encoding-id+ 3)

901

(defconstant +unicode-2.0-full-encoding-id+ 4)

902

(defconstant +microsoft-unicode-bmp-encoding-id+ 1)

903

(defconstant +microsoft-unicode-ucs4-encoding-id+ 10)

904

(defconstant +microsoft-symbol-encoding-id+ 0)

905

(defconstant +macintosh-roman-encoding-id+ 1)

906

907

;; Full list of microsoft language IDs is here:

908

;; http://www.microsoft.com/globaldev/reference/lcid-all.mspx

909

910

(defconstant +microsoft-us-english-language-id+ #x0409)

911

(defconstant +macintosh-english-language-id+ 1)

912

(defconstant +unicode-language-id+ 0)

913

914

(defclass name-entry ()

915

((font-loader

916

:initarg :font-loader

917

:accessor font-loader)

918

(platform-id

919

:initarg :platform-id

920

:accessor platform-id)

921

(encoding-id

922

:initarg :encoding-id

923

:accessor encoding-id)

924

(language-id

925

:initarg :language-id

926

:accessor language-id)

927

(name-id

928

:initarg :name-id

929

:accessor name-id)

930

(offset

931

:initarg :offset

932

:accessor offset

933

:documentation "The octet offset within the TrueType file stream

934

of the entry's data. *Not* the same as the offset in the NameRecord

935

structure, which is relative to the start of the string data for the

936

table.")

937

(entry-length

938

:initarg :entry-length

939

:accessor entry-length)

940

(value

941

:reader %value

942

:writer (setf value))

943

(octets

944

:reader %octets

945

:writer (setf data))))

946

947

(defmethod print-object ((name-entry name-entry) stream)

948

(print-unreadable-object (name-entry stream :type t)

949

(format stream "~A (~A/~A/~D)"

950

(aref *name-identifiers* (name-id name-entry))

951

(platform-id-name (platform-id name-entry))

952

(encoding-id-name (platform-id name-entry)

953

(encoding-id name-entry))

954

(language-id name-entry))))

955

956

(defun unicode-octets-to-string (octets)

957

(let ((string (make-string (/ (length octets) 2))))

958

(flet ((ref16 (i)

959

(+ (ash (aref octets i) 16)

960

(aref octets (1+ i)))))

961

(loop for i from 0 below (length octets) by 2

962

for j from 0

963

do (setf (char string j) (code-char (ref16 i))))

964

string)))

965

966

(defun macintosh-octets-to-string (octets)

967

(flet ((macroman->unicode (point)

968

(code-char (aref *macroman-translation-table* (1+ (ash point 1))))))

969

(let ((string (make-string (length octets))))

970

(dotimes (i (length octets) string)

971

(setf (schar string i) (macroman->unicode (aref octets i)))))))

972

973

(defmethod data ((self name-entry))

974

(unless (slot-boundp self 'octets)

975

(initialize-name-entry self))

976

(%octets self))

977

978

(defgeneric initialize-name-entry (name-entry)

979

(:method (name-entry)

980

(let ((stream (input-stream (font-loader name-entry)))

981

(octets (make-array (entry-length name-entry)

982

:element-type '(unsigned-byte 8)))

983

(value nil)

984

(platform-id (platform-id name-entry)))

985

(file-position stream (offset name-entry))

986

(read-sequence octets stream)

987

(cond ((or (= platform-id +unicode-platform-id+)

988

(= platform-id +microsoft-platform-id+))

989

(setf value (unicode-octets-to-string octets)))

990

((= platform-id +macintosh-platform-id+)

991

(setf value (macintosh-octets-to-string octets)))

992

(t

993

(error 'unsupported-value

994

:location "\"name\" table platform ID"

995

:actual-value platform-id

996

:expected-values (list +unicode-platform-id+

997

+microsoft-platform-id+

998

+macintosh-platform-id+))))

999

(setf (value name-entry) value

1000

(data name-entry) octets))))

1001

1002

(defgeneric value (name-entry)

1003

(:method (name-entry)

1004

(unless (slot-boundp name-entry 'value)

1005

(initialize-name-entry name-entry))

1006

(%value name-entry)))

1007

1008

(defun load-name-info (loader)

1009

(seek-to-table "name" loader)

1010

(let* ((stream (input-stream loader))

1011

(table-offset (file-position stream))

1012

(format (read-uint16 stream)))

1013

(unless (= format 0)

1014

(error 'unsupported-format

1015

:location "\"name\" table"

1016

:actual-value format

1017

:expected-values (list 0)))

1018

(let* ((count (read-uint16 stream))

1019

(values-offset (read-uint16 stream))

1020

(entries (make-array count)))

1021

(setf (name-entries loader) entries)

1022

(dotimes (i count)

1023

(let ((platform-id (read-uint16 stream))

1024

(encoding-id (read-uint16 stream))

1025

(language-id (read-uint16 stream))

1026

(name-id (read-uint16 stream))

1027

(length (read-uint16 stream))

1028

(offset (read-uint16 stream)))

1029

(setf (aref entries i)

1030

(make-instance 'name-entry

1031

:font-loader loader

1032

:platform-id platform-id

1033

:encoding-id encoding-id

1034

:language-id language-id

1035

:name-id name-id

1036

:entry-length length

1037

:offset (+ table-offset values-offset offset))))))))

1038

1039

;;;

1040

;;; Fetching info out of the name-entry vector

1041

;;;

1042

1043

(defun name-identifier-id (symbol)

1044

(let ((id (position symbol *name-identifiers*)))

1045

(if id

1046

id

1047

(error "Unknown NAME identifier: ~S" symbol))))

1048

1049

1050

(defmethod find-name-entry (platform-id encoding-id language-id name-id

1051

(font-loader font-loader))

1052

;; FIXME: this vector is sorted by platform ID, encoding ID,

1053

;; language ID, and name ID, in that order. Could bisect if it

1054

;; mattered.

1055

(loop for name-entry across (name-entries font-loader)

1056

when (and (or (null platform-id)

1057

(= (platform-id name-entry) platform-id))

1058

(or (null encoding-id)

1059

(= (encoding-id name-entry) encoding-id))

1060

(or (null language-id)

1061

(= (language-id name-entry) language-id))

1062

(or (null name-id)

1063

(= (name-id name-entry) name-id)))

1064

return name-entry))

1065

1066

(defmethod name-entry-value (name-designator (font-loader font-loader))

1067

(let* ((name-id (etypecase name-designator

1068

(keyword (name-identifier-id name-designator))

1069

(integer name-designator)))

1070

(entry (or (find-name-entry +unicode-platform-id+

1071

+unicode-2.0-encoding-id+

1072

+unicode-language-id+

1073

name-id

1074

font-loader)

1075

(find-name-entry +microsoft-platform-id+

1076

nil

1077

+microsoft-us-english-language-id+

1078

name-id

1079

font-loader)

1080

(find-name-entry +macintosh-platform-id+

1081

+macintosh-roman-encoding-id+

1082

+macintosh-english-language-id+

1083

name-id

1084

font-loader))))

1085

(when entry

1086

(value entry))))

1087

1088

1089

(defmethod postscript-name ((font-loader font-loader))

1090

(name-entry-value :postscript-name font-loader))

1091

1092

(defmethod family-name ((font-loader font-loader))

1093

(name-entry-value :font-family font-loader))

1094

1095

(defmethod subfamily-name ((font-loader font-loader))

1096

(name-entry-value :font-subfamily font-loader))

1097

1098

(defmethod full-name ((font-loader font-loader))

1099

(name-entry-value :full-name font-loader))

1100

1101

;;; cmap

1102

;; Loading data from the "cmap" table.

1103

1104

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/cmap

1105

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6cmap.html

1106

(deftype cmap-value-table ()

1107

`(array (unsigned-byte 16) (*)))

1108

1109

;;; FIXME: "unicode-cmap" is actually a format 4 character map that

1110

;;; happens to currently be loaded from a Unicode-compatible

1111

;;; subtable. However, other character maps (like Microsoft's Symbol

1112

;;; encoding) also use format 4 and could be loaded with these

1113

;;; "unicode" objects and functions.

1114

1115

(defclass unicode-cmap ()

1116

((segment-count :initarg :segment-count :reader segment-count)

1117

(end-codes :initarg :end-codes :reader end-codes)

1118

(start-codes :initarg :start-codes :reader start-codes)

1119

(id-deltas :initarg :id-deltas :reader id-deltas)

1120

(id-range-offsets :initarg :id-range-offsets :reader id-range-offsets)

1121

(glyph-indexes :initarg :glyph-indexes :accessor glyph-indexes)))

1122

1123

(defclass format-12-cmap ()

1124

((group-count :initarg :group-count :reader group-count)

1125

(start-codes :initarg :start-codes :reader start-codes)

1126

(end-codes :initarg :end-codes :reader end-codes)

1127

(glyph-starts :initarg :glyph-starts :accessor glyph-starts)))

1128

1129

(defun load-unicode-cmap-format12 (stream)

1130

"Load a Unicode character map of type 12 from STREAM starting at the

1131

current offset. Assumes format is already read and checked."

1132

(let* ((reserved (read-uint16 stream))

1133

(subtable-length (read-uint32 stream))

1134

(language-code (read-uint32 stream))

1135

(group-count (read-uint32 stream))

1136

(start-codes (make-array group-count

1137

:element-type '(unsigned-byte 32)

1138

:initial-element 0))

1139

(end-codes (make-array group-count

1140

:element-type '(unsigned-byte 32)

1141

:initial-element 0))

1142

(glyph-starts (make-array group-count

1143

:element-type '(unsigned-byte 32)

1144

:initial-element 0)))

1145

(declare (ignore reserved language-code subtable-length))

1146

(loop for i below group-count

1147

do (setf (aref start-codes i) (read-uint32 stream)

1148

(aref end-codes i) (read-uint32 stream)

1149

(aref glyph-starts i) (read-uint32 stream)))

1150

(make-instance 'format-12-cmap

1151

:group-count group-count

1152

:start-codes start-codes

1153

:end-codes end-codes

1154

:glyph-starts glyph-starts)))

1155

1156

(defun load-unicode-cmap (stream)

1157

"Load a Unicode character map of type 4 or 12 from STREAM starting at

1158

the current offset."

1159

(let ((format (read-uint16 stream)))

1160

(when (= format 12)

1161

(return-from load-unicode-cmap (load-unicode-cmap-format12 stream)))

1162

(when (/= format 4)

1163

(error 'unsupported-format

1164

:location "\"cmap\" subtable"

1165

:actual-value format

1166

:expected-values (list 4))))

1167

(let ((table-start (- (file-position stream) 2))

1168

(subtable-length (read-uint16 stream))

1169

(language-code (read-uint16 stream))

1170

(segment-count (/ (read-uint16 stream) 2))

1171

(search-range (read-uint16 stream))

1172

(entry-selector (read-uint16 stream))

1173

(range-shift (read-uint16 stream)))

1174

(declare (ignore language-code search-range entry-selector range-shift))

1175

(flet ((make-and-load-array (&optional (size segment-count))

1176

(loop with array = (make-array size

1177

                                             :element-type '(unsigned-byte 16)

1178

:initial-element 0)

1179

for i below size

1180

do (setf (aref array i) (read-uint16 stream))

1181

finally (return array)))

1182

(make-signed (i)

1183

(if (logbitp 15 i)

1184

(1- (- (logandc2 #xFFFF i)))

1185

i)))

1186

(let ((end-codes (make-and-load-array))

1187

(pad (read-uint16 stream))

1188

(start-codes (make-and-load-array))

1189

(id-deltas (make-and-load-array))

1190

(id-range-offsets (make-and-load-array))

1191

(glyph-index-array-size (/ (- subtable-length

1192

(- (file-position stream)

1193

table-start))

1194

2)))

1195

(declare (ignore pad))

1196

(make-instance 'unicode-cmap

1197

:segment-count segment-count

1198

:end-codes end-codes

1199

:start-codes start-codes

1200

;; these are really signed, so sign them

1201

:id-deltas (map 'vector #'make-signed id-deltas)

1202

:id-range-offsets id-range-offsets

1203

:glyph-indexes (make-and-load-array glyph-index-array-size))))))

1204

1205

1206

(defun %decode-format-4-cmap-code-point-index (code-point cmap index)

1207

"Return the index of the Unicode CODE-POINT in a format 4 CMAP, if

1208

present, otherwise NIL. Assumes INDEX points to the element of the

1209

CMAP arrays (END-CODES etc) corresponding to code-point."

1210

(with-slots (end-codes start-codes

1211

id-deltas id-range-offsets

1212

glyph-indexes)

1213

cmap

1214

(declare (type cmap-value-table

1215

end-codes start-codes

1216

id-range-offsets

1217

glyph-indexes))

1218

(let ((start-code (aref start-codes index))

1219

(end-code (aref end-codes index))

1220

(id-range-offset (aref id-range-offsets index))

1221

(id-delta (aref id-deltas index)))

1222

(cond

1223

((< code-point start-code)

1224

0)

1225

;; ignore empty final segment

1226

((and (= 65535 start-code end-code))

1227

0)

1228

((zerop id-range-offset)

1229

(logand #xFFFF (+ code-point id-delta)))

1230

(t

1231

(let* ((glyph-index-offset (- (+ index

1232

(ash id-range-offset -1)

1233

(- code-point start-code))

1234

(segment-count cmap)))

1235

(glyph-index (aref (glyph-indexes cmap)

1236

glyph-index-offset)))

1237

(logand #xFFFF

1238

(+ glyph-index id-delta))))))))

1239

1240

(defun %decode-format-12-cmap-code-point-index (code-point cmap index)

1241

"Return the index of the Unicode CODE-POINT in a format 12 CMAP, if

1242

present, otherwise NIL. Assumes INDEX points to the element of the

1243

CMAP arrays (END-CODES etc) corresponding to code-point."

1244

(with-slots (end-codes start-codes glyph-starts)

1245

cmap

1246

(declare (type (simple-array (unsigned-byte 32))

1247

end-codes start-codes glyph-starts))

1248

(let ((start-code (aref start-codes index))

1249

(start-glyph-id (aref glyph-starts index)))

1250

(if (< code-point start-code)

1251

0

1252

(+ start-glyph-id (- code-point start-code))))))

1253

1254

(defgeneric code-point-font-index-from-cmap (code-point cmap)

1255

(:documentation "Return the index of the Unicode CODE-POINT in

1256

CMAP, if present, otherwise NIL.")

1257

(:method (code-point (cmap unicode-cmap))

1258

(with-slots (end-codes)

1259

cmap

1260

(declare (type cmap-value-table end-codes))

1261

(dotimes (i (segment-count cmap) 1)

1262

(when (<= code-point (aref end-codes i))

1263

(return (%decode-format-4-cmap-code-point-index code-point cmap i))))))

1264

(:method (code-point (cmap format-12-cmap))

1265

(with-slots (end-codes)

1266

cmap

1267

(declare (type (simple-array (unsigned-byte 32)) end-codes))

1268

(dotimes (i (group-count cmap) 1)

1269

(when (<= code-point (aref end-codes i))

1270

(return

1271

(%decode-format-12-cmap-code-point-index code-point cmap i)))))))

1272

1273

(defmethod invert-character-map (font-loader)

1274

"Return a vector mapping font indexes to code points."

1275

(with-slots (start-codes end-codes)

1276

(character-map font-loader)

1277

(let ((points (make-array (glyph-count font-loader) :initial-element -1))

1278

(cmap (character-map font-loader)))

1279

(dotimes (i (length end-codes) points)

1280

(loop for j from (aref start-codes i) to (aref end-codes i)

1281

for font-index

1282

= (typecase cmap

1283

(unicode-cmap

1284

(%decode-format-4-cmap-code-point-index j cmap i))

1285

(format-12-cmap

1286

(%decode-format-12-cmap-code-point-index j cmap i))

1287

(t

1288

(code-point-font-index-from-cmap j cmap)))

1289

when (minusp (svref points font-index))

1290

do (setf (svref points font-index) j))))))

1291

1292

1293

(defgeneric code-point-font-index (code-point font-loader)

1294

(:documentation "Return the index of the Unicode CODE-POINT in

1295

FONT-LOADER, if present, otherwise NIL.")

1296

(:method (code-point font-loader)

1297

(code-point-font-index-from-cmap code-point (character-map font-loader))))

1298

1299

(defgeneric font-index-code-point (glyph-index font-loader)

1300

(:documentation "Return the code-point for a given glyph index.")

1301

(:method (glyph-index font-loader)

1302

(let ((point (aref (inverse-character-map font-loader) glyph-index)))

1303

(if (plusp point)

1304

point

1305

0))))

1306

1307

(defun %load-cmap-info (font-loader platform specific)

1308

(seek-to-table "cmap" font-loader)

1309

(with-slots (input-stream)

1310

font-loader

1311

(let ((start-pos (file-position input-stream))

1312

(version-number (read-uint16 input-stream))

1313

(subtable-count (read-uint16 input-stream))

1314

(foundp nil))

1315

(declare (ignore version-number))

1316

(loop repeat subtable-count

1317

for platform-id = (read-uint16 input-stream)

1318

for platform-specific-id = (read-uint16 input-stream)

1319

for offset = (+ start-pos (read-uint32 input-stream))

1320

when (and (= platform-id platform)

1321

(or (eql platform-specific-id specific)

1322

(and (consp specific)

1323

(member platform-specific-id specific))))

1324

do

1325

(file-position input-stream offset)

1326

(setf (character-map font-loader) (load-unicode-cmap input-stream))

1327

(setf (inverse-character-map font-loader)

1328

(invert-character-map font-loader)

1329

foundp t)

1330

(return))

1331

foundp)))

1332

1333

(defun %unknown-cmap-error (font-loader)

1334

(seek-to-table "cmap" font-loader)

1335

(with-slots (input-stream)

1336

font-loader

1337

(let ((start-pos (file-position input-stream))

1338

(version-number (read-uint16 input-stream))

1339

(subtable-count (read-uint16 input-stream))

1340

(cmaps nil))

1341

(declare (ignore version-number))

1342

(loop repeat subtable-count

1343

for platform-id = (read-uint16 input-stream)

1344

for platform-specific-id = (read-uint16 input-stream)

1345

for offset = (+ start-pos (read-uint32 input-stream))

1346

for pos = (file-position input-stream)

1347

do (file-position input-stream offset)

1348

(push (list (platform-id-name platform-id)

1349

(encoding-id-name platform-id platform-specific-id)

1350

:type (read-uint16 input-stream))

1351

cmaps)

1352

(file-position input-stream pos))

1353

(error "Could not find supported character map in font file~% available cmap tables = ~s"

1354

cmaps))))

1355

1356

(defmethod load-cmap-info ((font-loader font-loader))

1357

(or (%load-cmap-info font-loader +unicode-platform-id+

1358

+unicode-2.0-full-encoding-id+) ;; full unicode

1359

(%load-cmap-info font-loader +microsoft-platform-id+

1360

+microsoft-unicode-ucs4-encoding-id+) ;; full unicode

1361

(%load-cmap-info font-loader +microsoft-platform-id+

1362

+microsoft-unicode-bmp-encoding-id+) ;; bmp

1363

(%load-cmap-info font-loader +unicode-platform-id+

1364

+unicode-2.0-encoding-id+) ;; bmp

1365

(%load-cmap-info font-loader +unicode-platform-id+

1366

'(0 1 2 3 4)) ;; all except variation and last-resort

1367

(%load-cmap-info font-loader +microsoft-platform-id+

1368

+microsoft-symbol-encoding-id+) ;; ms symbol

1369

(%unknown-cmap-error font-loader)))

1370

1371

(defun available-character-maps (loader)

1372

(seek-to-table "cmap" loader)

1373

(let ((stream (input-stream loader)))

1374

(let ((start-pos (file-position stream))

1375

(version-number (read-uint16 stream))

1376

(subtable-count (read-uint16 stream)))

1377

(declare (ignore start-pos))

1378

(assert (zerop version-number))

1379

(dotimes (i subtable-count)

1380

(let ((platform-id (read-uint16 stream))

1381

(encoding-id (read-uint16 stream))

1382

(offset (read-uint32 stream)))

1383

(declare (ignore offset))

1384

(format t "~D (~A) - ~D (~A)~%"

1385

platform-id (platform-id-name platform-id)

1386

encoding-id (encoding-id-name platform-id encoding-id)))))))

1387

1388

;;; post

1389

;; "post" table functions

1390

1391

;; ref: https://docs.microsoft.com/en-us/typography/opentype/spec/post

1392

;; ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6post.html

1393

(defvar *standard-mac-glyph-names*

1394

#(".notdef"

1395

".null"

1396

"nonmarkingreturn"

1397

"space"

1398

"exclam"

1399

"quotedbl"

1400

"numbersign"

1401

"dollar"

1402

"percent"

1403

"ampersand"

1404

"quotesingle"

1405

"parenleft"

1406

"parenright"

1407

"asterisk"

1408

"plus"

1409

"comma"

1410

"hyphen"

1411

"period"

1412

"slash"

1413

"zero" "one" "two" "three" "four"

1414

"five" "six" "seven" "eight" "nine"

1415

"colon"

1416

"semicolon"

1417

"less"

1418

"equal"

1419

"greater"

1420

"question"

1421

"at"

1422

"A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M"

1423

"N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"

1424

"bracketleft"

1425

"backslash"

1426

"bracketright"

1427

"asciicircum"

1428

"underscore"

1429

"grave"

1430

"a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m"

1431

"n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"

1432

"braceleft"

1433

"bar"

1434

"braceright"

1435

"asciitilde"

1436

"Adieresis"

1437

"Aring"

1438

"Ccedilla"

1439

"Eacute"

1440

"Ntilde"

1441

"Odieresis"

1442

"Udieresis"

1443

"aacute"

1444

"agrave"

1445

"acircumflex"

1446

"adieresis"

1447

"atilde"

1448

"aring"

1449

"ccedilla"

1450

"eacute"

1451

"egrave"

1452

"ecircumflex"

1453

"edieresis"

1454

"iacute"

1455

"igrave"

1456

"icircumflex"

1457

"idieresis"

1458

"ntilde"

1459

"oacute"

1460

"ograve"

1461

"ocircumflex"

1462

"odieresis"

1463

"otilde"

1464

"uacute"

1465

"ugrave"

1466

"ucircumflex"

1467

"udieresis"

1468

"dagger"

1469

"degree"

1470

"cent"

1471

"sterling"

1472

"section"

1473

"bullet"

1474

"paragraph"

1475

"germandbls"

1476

"registered"

1477

"copyright"

1478

"trademark"

1479

"acute"

1480

"dieresis"

1481

"notequal"

1482

"AE"

1483

"Oslash"

1484

"infinity"

1485

"plusminus"

1486

"lessequal"

1487

"greaterequal"

1488

"yen"

1489

"mu"

1490

"partialdiff"

1491

"summation"

1492

"product"

1493

"pi"

1494

"integral"

1495

"ordfeminine"

1496

"ordmasculine"

1497

"Omega"

1498

"ae"

1499

"oslash"

1500

"questiondown"

1501

"exclamdown"

1502

"logicalnot"

1503

"radical"

1504

"florin"

1505

"approxequal"

1506

"Delta"

1507

"guillemotleft"

1508

"guillemotright"

1509

"ellipsis"

1510

"nonbreakingspace"

1511

"Agrave"

1512

"Atilde"

1513

"Otilde"

1514

"OE"

1515

"oe"

1516

"endash"

1517

"emdash"

1518

"quotedblleft"

1519

"quotedblright"

1520

"quoteleft"

1521

"quoteright"

1522

"divide"

1523

"lozenge"

1524

"ydieresis"

1525

"Ydieresis"

1526

"fraction"

1527

"currency"

1528

"guilsinglleft"

1529

"guilsinglright"

1530

"fi"

1531

"fl"

1532

"daggerdbl"

1533

"periodcentered"

1534

"quotesinglbase"

1535

"quotedblbase"

1536

"perthousand"

1537

"Acircumflex"

1538

"Ecircumflex"

1539

"Aacute"

1540

"Edieresis"

1541

"Egrave"

1542

"Iacute"

1543

"Icircumflex"

1544

"Idieresis"

1545

"Igrave"

1546

"Oacute"

1547

"Ocircumflex"

1548

"apple"

1549

"Ograve"

1550

"Uacute"

1551

"Ucircumflex"

1552

"Ugrave"

1553

"dotlessi"

1554

"circumflex"

1555

"tilde"

1556

"macron"

1557

"breve"

1558

"dotaccent"

1559

"ring"

1560

"cedilla"

1561

"hungarumlaut"

1562

"ogonek"

1563

"caron"

1564

"Lslash"

1565

"lslash"

1566

"Scaron"

1567

"scaron"

1568

"Zcaron"

1569

"zcaron"

1570

"brokenbar"

1571

"Eth"

1572

"eth"

1573

"Yacute"

1574

"yacute"

1575

"Thorn"

1576

"thorn"

1577

"minus"

1578

"multiply"

1579

"onesuperior"

1580

"twosuperior"

1581

"threesuperior"

1582

"onehalf"

1583

"onequarter"

1584

"threequarters"

1585

"franc"

1586

"Gbreve"

1587

"gbreve"

1588

"Idotaccent"

1589

"Scedilla"

1590

"scedilla"

1591

"Cacute"

1592

"cacute"

1593

"Ccaron"

1594

"ccaron"

1595

"dcroat"))

1596

1597

(defun load-post-format-2 (names stream size-without-header)

1598

(let* ((standard-names *standard-mac-glyph-names*)

1599

(name-count (length names))

1600

(glyph-count (read-uint16 stream)))

1601

(when (/= glyph-count name-count)

1602

(warn "Glyph count in \"post\" table (~D) ~

1603

does not match glyph count in \"maxp\" table (~D). ~

1604

This font may be broken."

1605

glyph-count name-count))

1606

;; This is done in a couple passes. First, initialize the names

1607

;; tables with indexes into either the standard table or the

1608

;; pstring table.

1609

(dotimes (i glyph-count)

1610

(setf (aref names i) (read-uint16 stream)))

1611

;; Next, read the pstring table into a vector.

1612

;; We can't know the number of extended glyph names in advance but

1613

;; GLYPH-COUNT should be enough in many cases. Note that we cannot

1614

;; compute the number of extended glyph names from the indices

1615

;; preceding the indices might not reference all names.

1616

(let ((pstrings (make-array glyph-count :adjustable t :fill-pointer 0)))

1617

(loop with position = (+ 2 (* 2 glyph-count))

1618

while (< position size-without-header)

1619

do (let ((string (read-pstring stream)))

1620

(vector-push-extend string pstrings)

1621

(incf position (1+ (length string)))))

1622

;; Finally, replace the indexes with names.

1623

(loop for i below glyph-count

1624

for name-index across names

1625

do (setf (aref names i)

1626

(if (< name-index 258)

1627

(aref standard-names name-index)

1628

(aref pstrings (- name-index 258))))))))

1629

1630

(defun load-post-format-3 (names stream)

1631

(declare (ignore stream))

1632

(fill names nil))

1633

1634

(defmethod load-post-info ((font-loader font-loader))

1635

(let* ((names (make-array (glyph-count font-loader)

1636

:initial-element 0))

1637

(stream (input-stream font-loader))

1638

(table-info (table-info "post" font-loader)))

1639

(seek-to-table table-info font-loader)

1640

(let ((format (read-uint32 stream))

1641

(header-size 32))

1642

(when (/= format #x00020000 #x00030000)

1643

(error 'unsupported-format

1644

:location "\"post\" table"

1645

:expected-values (list #x00020000 #x00030000)

1646

:actual-value format))

1647

(setf (italic-angle font-loader) (read-fixed stream)

1648

(underline-position font-loader) (read-fword stream)

1649

(underline-thickness font-loader) (read-fword stream)

1650

(fixed-pitch-p font-loader) (plusp (read-uint32 stream))

1651

(postscript-glyph-names font-loader) names)

1652

;; skip minMemType* fields

1653

(advance-file-position stream (- header-size 16))

1654

(case format

1655

(#x00020000 (load-post-format-2

1656

names stream (- (size table-info) header-size)))

1657

(#x00030000 (load-post-format-3 names stream))))))

1658

1659

(defun postscript-uni-name-p (name)

1660

(let ((end (or (position #\. name) (length name))))

1661

(and (= end 7)

1662

(= (mismatch "uni" name) 3)

1663

(loop for i from 3 below end

1664

always (digit-char-p (char name i) 16)))))

1665

1666

(defun postscript-name-code-point (name)

1667

   "Returns, if available, the interpretation of the PostScript name NAME as a Unicode code point specifier.

1668

Ref: http://partners.adobe.com/public/developer/opentype/index_glyph.html"

1669

(when (postscript-uni-name-p name)

1670

(parse-integer name :start 3 :end 7 :radix 16)))

1671

1672

;;; hhea

1673

;; Loading data from the "hhea" table.

1674

1675

;; ref: https://learn.microsoft.com/en-us/typography/opentype/spec/hhea

1676

;; ref: https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6hhea.html

1677

(defmethod load-hhea-info ((font-loader font-loader))

1678

(seek-to-table "hhea" font-loader)

1679

(with-slots (input-stream ascender descender line-gap max-width)

1680

font-loader

1681

(let ((version (read-fixed input-stream)))

1682

(check-version "\"hhea\" table" version #x00010000))

1683

(setf ascender (read-fword input-stream)

1684

descender (read-fword input-stream)

1685

line-gap (read-fword input-stream)

1686

max-width (read-ufword input-stream))))

1687

1688

(defmethod horizontal-metrics-count ((font-loader font-loader))

1689

(seek-to-table "hhea" font-loader)

1690

(with-slots (input-stream) font-loader

1691

;; Skip to the end, since all we care about is the last item

1692

(advance-file-position input-stream 34)

1693

(read-uint16 input-stream)))

1694

1695

;;; hmtx

1696

;; Loading data from the "hmtx" table.

1697

1698

;; ref: https://learn.microsoft.com/en-us/typography/opentype/spec/hmtx

1699

;; ref: https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6hmtx.html

1700

(defmethod load-hmtx-info ((font-loader font-loader))

1701

(let* ((horizontal-metrics-count (horizontal-metrics-count font-loader))

1702

(advance-widths (make-array horizontal-metrics-count))

1703

(left-side-bearings (make-array horizontal-metrics-count)))

1704

(seek-to-table "hmtx" font-loader)

1705

(with-slots (input-stream) font-loader

1706

(dotimes (i horizontal-metrics-count)

1707

(setf (svref advance-widths i) (read-uint16 input-stream))

1708

(setf (svref left-side-bearings i) (read-int16 input-stream))))

1709

(setf (advance-widths font-loader) advance-widths

1710

(left-side-bearings font-loader) left-side-bearings)))

1711

1712

;;; vhea

1713

;; Loading data from the "vhea" table.

1714

1715

;; ref: https://learn.microsoft.com/en-us/typography/opentype/spec/vhea

1716

;; ref: https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6vhea.html

1717

1718

;; Tables 'vhea' and 'vmtx' are not present in some fonts. For that reason we

1719

;; have a fallback where metrics are supplanted with default values based on

1720

;; horizontal metrics.

1721

(defmethod load-vhea-info ((font-loader font-loader))

1722

(unless (table-info "vhea" font-loader)

1723

(setf (vhea-missing-p font-loader) t)

1724

(let ((dx (/ (max-width font-loader) 2)))

1725

(with-slots (vascender vdescender)

1726

font-loader

1727

(setf vascender dx

1728

vdescender (- dx))))

1729

(return-from load-vhea-info))

1730

(seek-to-table "vhea" font-loader)

1731

(with-slots (input-stream vascender vdescender)

1732

font-loader

1733

(let ((version (read-fixed input-stream)))

1734

(check-version "\"vhea\" table" version #x00010000 #x00011000))

1735

(setf vascender (read-fword input-stream)

1736

vdescender (read-fword input-stream))))

1737

1738

(defmethod vertical-metrics-count ((font-loader font-loader))

1739

(when (or (vhea-missing-p font-loader)

1740

(null (table-info "vhea" font-loader)))

1741

;; (warn "Table 'vhea' is missing.")

1742

(setf (vhea-missing-p font-loader) t)

1743

(return-from vertical-metrics-count))

1744

(seek-to-table "vhea" font-loader)

1745

(with-slots (input-stream) font-loader

1746

;; Skip to the end, since all we care about is the last item

1747

(advance-file-position input-stream 34)

1748

(read-uint16 input-stream)))

1749

1750

;;; vmtx

1751

;; Loading data from the 'vmtx' table.

1752

1753

;; ref: https://learn.microsoft.com/en-us/typography/opentype/spec/vmtx

1754

;; ref: https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6vmtx.html

1755

1756

;; Tables 'vhea' and 'vmtx' are not present in some fonts. For that reason we

1757

;; have a fallback where metrics are supplanted with default values based on

1758

;; horizontal metrics.

1759

(defmethod load-vmtx-info ((font-loader font-loader))

1760

(when (or (vhea-missing-p font-loader)

1761

(null (table-info "vmtx" font-loader)))

1762

(setf (vmtx-missing-p font-loader) t)

1763

(let ((line-height (- (ascender font-loader) (descender font-loader))))

1764

;; TOP-SIDE-BEARING depends on individual glyph metric YMAX.

1765

(setf (advance-heights font-loader)

1766

(make-array 1 :initial-element line-height)))

1767

(return-from load-vmtx-info))

1768

(let* ((vertical-metrics-count (vertical-metrics-count font-loader))

1769

(advance-heights (make-array vertical-metrics-count))

1770

(top-side-bearings (make-array vertical-metrics-count)))

1771

(seek-to-table "vmtx" font-loader)

1772

(with-slots (input-stream) font-loader

1773

(dotimes (i vertical-metrics-count)

1774

(setf (svref advance-heights i) (read-uint16 input-stream))

1775

(setf (svref top-side-bearings i) (read-int16 input-stream))))

1776

(setf (advance-heights font-loader) advance-heights

1777

(top-side-bearings font-loader) top-side-bearings)))

1778

1779

;;; glyf

1780

;; Loading data from the 'glyf' table.

1781

(defclass control-point ()

1782

((x :initarg :x :accessor cp-x)

1783

(y :initarg :y :accessor cp-y)

1784

(on-curve-p :initarg :on-curve-p :reader on-curve-p)))

1785

1786

(defun make-control-point (x y on-curve-p)

1787

(make-instance 'control-point

1788

:x x

1789

:y y

1790

:on-curve-p on-curve-p))

1791

1792

(defmethod print-object ((control-point control-point) stream)

1793

(print-unreadable-object (control-point stream :type t)

1794

(format stream "~D,~D~:[~;*~]"

1795

(cp-x control-point) (cp-y control-point) (on-curve-p control-point))))

1796

1797

(defmacro do-contour-segments* ((p1 p2) contour &body body)

1798

(let ((length (gensym))

1799

(i (gensym))

1800

(stack (gensym))

1801

(next (gensym))

1802

(next-point (gensym "NEXT-POINT"))

1803

(midpoint (gensym "MIDPOINT"))

1804

(contour* (gensym))

1805

(loop (gensym "LOOP"))

1806

(body-tag (gensym "BODY"))

1807

(done-tag (gensym "DONE"))

1808

(mid p1)

1809

(end p2))

1810

`(let* ((,i 1)

1811

(,contour* ,contour)

1812

(,length (length ,contour*))

1813

,stack ,next ,mid ,end)

1814

(unless (zerop ,length)

1815

(unless (on-curve-p (aref ,contour* 0))

1816

(setf ,stack (aref ,contour* 0)))

1817

(flet ((,next-point ()

1818

(when (< ,i ,length)

1819

(prog1 (aref ,contour* ,i) (incf ,i))))

1820

(,midpoint (p0 p1)

1821

(make-control-point (/ (+ (cp-x p0) (cp-x p1)) 2)

1822

(/ (+ (cp-y p0) (cp-y p1)) 2)

1823

t)))

1824

(tagbody

1825

,loop

1826

(setf ,mid nil

1827

,next (,next-point))

1828

(unless ,next

1829

(setf ,mid ,stack

1830

,end (aref ,contour* 0))

1831

(cond

1832

((on-curve-p ,end)

1833

(go ,body-tag))

1834

(,stack

1835

(setf ,mid ,stack

1836

,end (,midpoint ,stack ,end))

1837

(go ,body-tag))

1838

(t (go ,done-tag))))

1839

(if (on-curve-p ,next)

1840

(setf ,end ,next

1841

,mid ,stack

1842

,stack nil)

1843

(cond (,stack

1844

(setf ,mid ,stack

1845

,end (,midpoint ,stack ,next)

1846

,stack ,next))

1847

(t

1848

(setf ,stack ,next)

1849

(go ,loop))))

1850

,body-tag

1851

,@body

1852

(when ,next

1853

(go ,loop))

1854

,done-tag))))))

1855

1856

(defun start-of-contour (contour)

1857

"If first point of a contour is on the curve, return it, otherwise

1858

find and return previous (possibly implicit) point on the curve."

1859

(let ((first (aref contour 0)))

1860

(if (on-curve-p first)

1861

first

1862

(let ((last (aref contour (1- (length contour)))))

1863

(if (on-curve-p last)

1864

last

1865

;; both are off curve, return the implicit on-curve point

1866

(make-control-point (/ (+ (cp-x first) (cp-x last)) 2)

1867

(/ (+ (cp-y first) (cp-y last)) 2)

1868

t))))))

1869

1870

(defmacro do-contour-segments ((p0 p1 p2) contour &body body)

1871

"A contour is made up of segments. A segment may be a straight line

1872

or a curve. For each segment, bind the P0 and P2 variables to the

1873

start and end points of the segment. If the segment is a curve, set P1

1874

to the control point of the curve, otherwise set P1 to NIL."

1875

;; This macro started out life as a function and was converted.

1876

(let ((start p0)

1877

(contour* (gensym "CONTOUR")))

1878

`(let ((,contour* ,contour))

1879

(when (plusp (length ,contour*))

1880

(let ((,start (start-of-contour ,contour*)))

1881

(do-contour-segments* (,p1 ,p2)

1882

,contour*

1883

(progn ,@body)

1884

(setf ,start ,p2)))))))

1885

1886

(defun explicit-contour-points (contour)

1887

(let ((new-contour (make-array (length contour)

1888

:adjustable t

1889

:fill-pointer 0)))

1890

(when (and (plusp (length contour))

1891

(on-curve-p (aref contour 0)))

1892

(vector-push-extend (aref contour 0) new-contour))

1893

(do-contour-segments* (p1 p2)

1894

contour

1895

(when p1

1896

(vector-push-extend p1 new-contour))

1897

(unless (eql p2 (aref contour 0))

1898

(vector-push-extend p2 new-contour)))

1899

new-contour))

1900

1901

1902

;;; Locating a glyph's contours and bounding box in the font loader's

1903

;;; stream, and loading them

1904

1905

(defparameter *empty-contours*

1906

(make-array 0 :element-type '(signed-byte 16)))

1907

1908

(defparameter *empty-bounding-box*

1909

(make-array 4

1910

:initial-element 0

1911

:element-type '(signed-byte 16)))

1912

1913

(defun empty-bounding-box ()

1914

(copy-seq *empty-bounding-box*))

1915

1916

(defun empty-contours ()

1917

(copy-seq *empty-contours*))

1918

1919

(defun dump-compound-flags (flags)

1920

(format t "XXX flags=~16,'0B~%" flags)

1921

(let ((meanings '((0 . ARG_1_AND_2_ARE_WORDS)

1922

(1 . ARGS_ARE_XY_VALUES)

1923

(2 . ROUND_XY_TO_GRID)

1924

(3 . WE_HAVE_A_SCALE)

1925

(4 . OBSOLETE)

1926

(5 . MORE_COMPONENTS)

1927

(6 . WE_HAVE_AN_X_AND_Y_SCALE)

1928

(7 . WE_HAVE_A_TWO_BY_TWO)

1929

(8 . WE_HAVE_INSTRUCTIONS)

1930

(9 . USE_MY_METRICS)

1931

(10 . OVERLAP_COMPOUND))))

1932

(loop for ((bit . meaning)) on meanings

1933

do (when (logbitp bit flags)

1934

(format t "...~A~%" meaning)))))

1935

1936

(defun transform-option-count (flags)

1937

(let ((scale-p 3)

1938

(xy-scale-p 6)

1939

(2*2-scale-p 7))

1940

(cond ((logbitp scale-p flags) 1)

1941

((logbitp xy-scale-p flags) 2)

1942

((logbitp 2*2-scale-p flags) 4)

1943

(t 0))))

1944

1945

(defun make-transformer (a b c d e f)

1946

"Given the elements of the transformation matrix specified by A, B,

1947

C, D, E, and F, return a function of two arguments that returns the

1948

arguments transformed as multiple values.

1949

Ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6glyf.html"

1950

(let ((m (max (abs a) (abs b)))

1951

(n (max (abs c) (abs d))))

1952

(when (<= (abs (- (abs a) (abs b))) 33/65536)

1953

(setf m (* m 2)))

1954

(when (<= (abs (- (abs c) (abs d))) 33/65536)

1955

(setf n (* n 2)))

1956

(lambda (x y)

1957

(values (* m (+ (* (/ a m) x)

1958

(* (/ c m) y)

1959

e))

1960

(* n (+ (* (/ b n) x)

1961

(* (/ d n) y)

1962

f))))))

1963

1964

(defun transform-contours (fn contours)

1965

"Call FN with the X and Y coordinates of each point of each contour

1966

in the vector CONTOURS. FN should return two values, which are used to

1967

update the X and Y values of each point."

1968

(loop for contour across contours do

1969

(loop for p across contour do

1970

(setf (values (cp-x p) (cp-y p))

1971

(funcall fn (cp-x p) (cp-y p))))))

1972

1973

(defun merge-contours (contours-list)

1974

(let* ((total-contours (loop for contours in contours-list

1975

summing (length contours)))

1976

(merged (make-array total-contours))

1977

(i 0))

1978

(dolist (contours contours-list merged)

1979

(loop for contour across contours do

1980

(setf (aref merged i) contour)

1981

(incf i)))))

1982

1983

(defvar *compound-contour-loop-check*)

1984

1985

(defun read-compound-contours (loader)

1986

(let ((contours-list '())

1987

(stream (input-stream loader)))

1988

(loop

1989

(let ((flags (read-uint16 stream))

1990

(font-index (read-uint16 stream)))

1991

(let ((position (file-position stream))

1992

(contours (read-contours-at-index font-index loader)))

1993

(push contours contours-list)

1994

(file-position stream position)

1995

(let ((args-words-p (logbitp 0 flags))

1996

(args-xy-values-p (logbitp 1 flags))

1997

(more-components-p (logbitp 5 flags))

1998

arg1 arg2)

1999

(cond ((and args-words-p args-xy-values-p)

2000

(setf arg1 (read-int16 stream)

2001

arg2 (read-int16 stream)))

2002

(args-words-p

2003

(setf arg1 (read-uint16 stream)

2004

arg2 (read-uint16 stream))

2005

(error "Compound glyphs relative to indexes not yet supported"))

2006

(args-xy-values-p

2007

(setf arg1 (read-int8 stream)

2008

arg2 (read-int8 stream)))

2009

(t

2010

(setf arg1 (read-uint8 stream)

2011

arg2 (read-uint8 stream))

2012

(error "Compound glyphs relative to indexes not yet supported")))

2013

;; Transform according to the transformation matrix

2014

(let ((a 1.0) (b 0.0) (c 0.0) (d 1.0)

2015

(e arg1) (f arg2))

2016

(ecase (transform-option-count flags)

2017

(0)

2018

(1

2019

(setf a (setf d (read-fixed2.14 stream))))

2020

(2

2021

(setf a (read-fixed2.14 stream)

2022

d (read-fixed2.14 stream)))

2023

(4

2024

(setf a (read-fixed2.14 stream)

2025

b (read-fixed2.14 stream)

2026

c (read-fixed2.14 stream)

2027

d (read-fixed2.14 stream))))

2028

(let ((transform-fn (make-transformer a b c d e f)))

2029

(transform-contours transform-fn contours)))

2030

(unless more-components-p

2031

(return (merge-contours contours-list)))))))))

2032

2033

(defun read-points-vector (stream flags count axis)

2034

(let ((points (make-array count :fill-pointer 0))

2035

(short-index (if (eql axis :x) 1 2))

2036

(same-index (if (eql axis :x) 4 5)))

2037

(flet ((save-point (point)

2038

(vector-push point points)))

2039

(loop for flag across flags

2040

for short-p = (logbitp short-index flag)

2041

for same-p = (logbitp same-index flag)

2042

do (cond (short-p

2043

(let ((new-point (read-uint8 stream)))

2044

(save-point (if same-p new-point (- new-point)))))

2045

(t

2046

(if same-p

2047

(save-point 0)

2048

(save-point (read-int16 stream)))))))

2049

points))

2050

2051

(defun read-simple-contours (contour-count stream)

2052

"With the stream positioned immediately after the glyph bounding

2053

box, read the contours data from STREAM and return it as a vector."

2054

(let ((contour-endpoint-indexes (make-array contour-count)))

2055

(loop for i below contour-count

2056

for endpoint-index = (read-uint16 stream)

2057

do (setf (svref contour-endpoint-indexes i) endpoint-index))

2058

;; instructions

2059

(let ((n-points (1+ (svref contour-endpoint-indexes

2060

(1- contour-count))))

2061

(instruction-length (read-uint16 stream)))

2062

(loop for i below instruction-length

2063

do (read-byte stream))

2064

;; read the flags

2065

(let ((flags (make-array n-points)))

2066

(loop with i = 0

2067

while (< i n-points) do

2068

(let ((flag-byte (read-uint8 stream)))

2069

(setf (svref flags i) flag-byte)

2070

(incf i)

2071

(when (logbitp 3 flag-byte)

2072

(let ((n-repeats (read-uint8 stream)))

2073

(loop repeat n-repeats do

2074

(setf (svref flags i) flag-byte)

2075

(incf i))))))

2076

(let ((x-points (read-points-vector stream flags n-points :x ))

2077

(y-points (read-points-vector stream flags n-points :y))

2078

(control-points (make-array n-points :fill-pointer 0))

2079

(contours (make-array contour-count)))

2080

(loop for x-point across x-points

2081

for y-point across y-points

2082

for flag across flags

2083

for x = x-point then (+ x x-point)

2084

for y = y-point then (+ y y-point)

2085

do

2086

(vector-push-extend (make-control-point x y

2087

                                                         (logbitp 0 flag))

2088

control-points))

2089

(loop for start = 0 then (1+ end)

2090

for end across contour-endpoint-indexes

2091

for i from 0

2092

do (setf (svref contours i)

2093

(subseq control-points start (1+ end))))

2094

contours)))))

2095

2096

(defmacro with-compound-contour-loop (() &body body)

2097

`(let ((*compound-contour-loop-check*

2098

(if (boundp '*compound-contour-loop-check*)

2099

*compound-contour-loop-check*

2100

(make-hash-table))))

2101

,@body))

2102

2103

(defun read-contours-at-index (index loader)

2104

"Read the contours at glyph index INDEX, discarding bounding box

2105

information."

2106

(let ((stream (input-stream loader)))

2107

(file-position stream (+ (table-position "glyf" loader)

2108

(glyph-location index loader)))

2109

(let ((contour-count (read-int16 stream))

2110

(xmin (read-int16 stream))

2111

(ymin (read-int16 stream))

2112

(xmax (read-int16 stream))

2113

(ymax (read-int16 stream)))

2114

(declare (ignore xmin ymin xmax ymax))

2115

(if (= contour-count -1)

2116

(with-compound-contour-loop ()

2117

;; some fonts have compound contours that contain

2118

;; themselves, so we try to detect that.

2119

(when (gethash index *compound-contour-loop-check*)

2120

(return-from read-contours-at-index

2121

(gethash index *compound-contour-loop-check*)))

2122

;; store a value for when we detect a loop

2123

(setf (gethash index *compound-contour-loop-check*)

2124

#())

2125

;; It is reasonable for a particular contour to be

2126

;; included multiple times within the tree of compounds,

2127

;; though, so for that case we save the value and reuse

2128

;; it.

2129

(setf (gethash index *compound-contour-loop-check*)

2130

(read-compound-contours loader)))

2131

(read-simple-contours contour-count stream)))))

2132

2133

;;; glyph

2134

;; An object for working with glyphs from the font. Some fields are

2135

;; lazily loaded from the input-stream of the font-loader when needed.

2136

(defclass glyph ()

2137

((font-loader

2138

:initarg :font-loader

2139

:reader font-loader

2140

:documentation "The font-loader from which this glyph originates.")

2141

(font-index

2142

:initarg :font-index

2143

:accessor font-index

2144

:documentation "The index of this glyph within the font file, used

2145

to look up information in various structures in the truetype file.")

2146

(code-point

2147

:initarg :code-point

2148

:accessor code-point)

2149

(contours

2150

:initarg :contours

2151

:accessor contours)

2152

(bounding-box

2153

:initarg :bounding-box

2154

:accessor bounding-box)))

2155

2156

(defmethod initialize-instance :after ((glyph glyph)

2157

                                        &key code-point font-index font-loader

2158

&allow-other-keys)

2159

(flet ((argument-error (name)

2160

(error "Missing required initarg ~S" name)))

2161

(unless font-loader

2162

(argument-error :font-loader))

2163

(cond ((and code-point font-index)) ;; do nothing

2164

(code-point

2165

(setf (font-index glyph)

2166

(code-point-font-index code-point font-loader)))

2167

(font-index

2168

(let ((code-point (font-index-code-point font-index font-loader)))

2169

(when (zerop code-point)

2170

(setf code-point

2171

(or (postscript-name-code-point (postscript-name glyph))

2172

code-point)))

2173

(setf (code-point glyph) code-point)))

2174

(t

2175

(argument-error (list :font-index :code-point))))))

2176

2177

(defmethod print-object ((glyph glyph) stream)

2178

(print-unreadable-object (glyph stream :type t :identity nil)

2179

;; FIXME: Is this really going to be Unicode?

2180

(format stream "~S U+~4,'0X"

2181

(postscript-name glyph)

2182

(code-point glyph))))

2183

2184

;;;; Horizontal metrics

2185

(defgeneric left-side-bearing (object)

2186

(:method ((glyph glyph))

2187

(bounded-aref (left-side-bearings (font-loader glyph))

2188

(font-index glyph))))

2189

2190

(defmethod (setf left-side-bearing) (new-value glyph)

2191

(setf (bounded-aref (left-side-bearings (font-loader glyph))

2192

(font-index glyph))

2193

new-value))

2194

2195

(defgeneric advance-width (object)

2196

(:method ((glyph glyph))

2197

(bounded-aref (advance-widths (font-loader glyph))

2198

(font-index glyph))))

2199

2200

(defmethod (setf advance-width) (new-value (glyph glyph))

2201

(setf (bounded-aref (advance-widths (font-loader glyph))

2202

(font-index glyph))

2203

new-value))

2204

2205

;;;; Vertical metrics

2206

(defgeneric top-side-bearing (object)

2207

(:method ((glyph glyph))

2208

(let ((loader (font-loader glyph)))

2209

(if (vmtx-missing-p loader)

2210

(- (ascender loader) (bbox-ymax glyph))

2211

(bounded-aref (top-side-bearings (font-loader glyph))

2212

(font-index glyph))))))

2213

2214

(defmethod (setf top-side-bearing) (new-value glyph)

2215

(setf (bounded-aref (top-side-bearings (font-loader glyph))

2216

(font-index glyph))

2217

new-value))

2218

2219

(defgeneric advance-height (object)

2220

(:method ((glyph glyph))

2221

(bounded-aref (advance-heights (font-loader glyph))

2222

(font-index glyph))))

2223

2224

(defmethod (setf advance-height) (new-value (glyph glyph))

2225

(setf (bounded-aref (advance-heights (font-loader glyph))

2226

(font-index glyph))

2227

new-value))

2228

2229

;;;; Kerning

2230

(defgeneric kerning-offset (left right loader))

2231

2232

(defmethod kerning-offset ((left-glyph glyph) (right-glyph glyph)

2233

(font-loader font-loader))

2234

(let ((kerning-table-key (logior (ash (font-index left-glyph) 16)

2235

(font-index right-glyph))))

2236

(gethash kerning-table-key (kerning-table font-loader) 0)))

2237

2238

(defmethod kerning-offset ((left character) (right character)

2239

(font-loader font-loader))

2240

(kerning-offset (find-glyph left font-loader)

2241

(find-glyph right font-loader)

2242

font-loader))

2243

2244

(defmethod kerning-offset ((left null) right font-loader)

2245

(declare (ignore left right font-loader))

2246

0)

2247

2248

(defmethod kerning-offset (left (right null) font-loader)

2249

(declare (ignore left right font-loader))

2250

0)

2251

2252

(defgeneric kerned-advance-width (object next)

2253

(:method ((object glyph) next)

2254

(+ (advance-width object)

2255

(kerning-offset object next (font-loader object)))))

2256

2257

(defgeneric location (object)

2258

(:method ((glyph glyph))

2259

(with-slots (font-index font-loader)

2260

glyph

2261

(+ (table-position "glyf" font-loader)

2262

(glyph-location font-index font-loader)))))

2263

2264

(defgeneric data-size (object)

2265

(:method ((glyph glyph))

2266

(with-slots (font-index font-loader)

2267

glyph

2268

(- (glyph-location (1+ font-index) font-loader)

2269

(glyph-location font-index font-loader)))))

2270

2271

;;;; Initializing delayed data

2272

(defmethod initialize-bounding-box ((glyph glyph))

2273

(if (zerop (data-size glyph))

2274

(setf (bounding-box glyph) (empty-bounding-box))

2275

(let ((stream (input-stream (font-loader glyph))))

2276

;; skip contour-count

2277

(file-position stream (+ (location glyph) 2))

2278

(setf (bounding-box glyph)

2279

(vector (read-fword stream)

2280

(read-fword stream)

2281

(read-fword stream)

2282

(read-fword stream))))))

2283

2284

(defmethod initialize-contours ((glyph glyph))

2285

(if (zerop (data-size glyph))

2286

(setf (contours glyph) (empty-contours))

2287

(let ((stream (input-stream (font-loader glyph))))

2288

(file-position stream (location glyph))

2289

(let ((contour-count (read-int16 stream)))

2290

;; skip glyph bounding box, 4 FWords

2291

(advance-file-position stream 8)

2292

(if (= contour-count -1)

2293

(setf (contours glyph)

2294

(read-compound-contours (font-loader glyph)))

2295

(setf (contours glyph)

2296

(read-simple-contours contour-count stream)))))))

2297

2298

(defmethod bounding-box :before ((glyph glyph))

2299

(unless (slot-boundp glyph 'bounding-box)

2300

(initialize-bounding-box glyph)))

2301

2302

(defmethod contours :before ((glyph glyph))

2303

(unless (slot-boundp glyph 'contours)

2304

(initialize-contours glyph)))

2305

2306

(defgeneric contour-count (object)

2307

(:method (object)

2308

(length (contours object))))

2309

2310

(defgeneric contour (object idex)

2311

(:method (object index)

2312

(aref (contours object) index)))

2313

2314

(defmacro do-contours ((contour object &optional result) &body body)

2315

(let ((i (gensym))

2316

(obj (gensym)))

2317

`(let ((,obj ,object))

2318

(dotimes (,i (contour-count ,obj) ,result)

2319

(let ((,contour (contour ,obj ,i)))

2320

,@body)))))

2321

2322

(defgeneric right-side-bearing (object)

2323

(:method ((glyph glyph))

2324

(- (advance-width glyph)

2325

(- (+ (left-side-bearing glyph) (bbox-xmax glyph))

2326

(bbox-xmin glyph)))))

2327

2328

;;;; Producing a bounding box for a sequence of characters

2329

(defgeneric string-bounding-box (string loader &key kerning))

2330

2331

(defmethod string-bounding-box (string (font-loader font-loader)

2332

&key (kerning t))

2333

(cond ((zerop (length string))

2334

(empty-bounding-box))

2335

((= 1 (length string))

2336

(copy-seq (bounding-box (find-glyph (char string 0) font-loader))))

2337

(t

2338

(let ((origin 0)

2339

(left (find-glyph (char string 0) font-loader))

2340

(xmin most-positive-fixnum) (ymin most-positive-fixnum)

2341

(xmax most-negative-fixnum) (ymax most-negative-fixnum))

2342

(flet ((update-bounds (glyph)

2343

(setf xmin (min (+ (bbox-xmin glyph) origin) xmin)

2344

xmax (max (+ (bbox-xmax glyph) origin) xmax)

2345

ymin (min (bbox-ymin glyph) ymin)

2346

ymax (max (bbox-ymax glyph) ymax))))

2347

(update-bounds left)

2348

(loop for i from 1 below (length string)

2349

for glyph = (find-glyph (char string i) font-loader)

2350

do

2351

(incf origin (advance-width left))

2352

(when kerning

2353

(incf origin (kerning-offset left glyph font-loader)))

2354

(setf left glyph)

2355

(update-bounds glyph)))

2356

(vector xmin ymin xmax ymax)))))

2357

2358

;;;; Producing glyphs from loaders

2359

(defgeneric glyph-exists-p (character font-loader)

2360

(:method ((character glyph) font-loader)

2361

(let ((index (font-index character)))

2362

(not (zerop index))))

2363

(:method (character font-loader)

2364

(glyph-exists-p (find-glyph character font-loader) font-loader)))

2365

2366

(defgeneric find-glyph (character font-loader)

2367

(:documentation "Find the glyph object for CHARACTER in FONT-LOADER

2368

and return it. If CHARACTER is an integer, treat it as a Unicode code

2369

point. If CHARACTER is a Lisp character, treat its char-code as a

2370

Unicode code point.")

2371

(:method ((character integer) (font-loader font-loader))

2372

(index-glyph (code-point-font-index character font-loader) font-loader))

2373

(:method ((character character) (font-loader font-loader))

2374

(find-glyph (char-code character) font-loader)))

2375

2376

(defgeneric index-glyph (index font-loader)

2377

(:documentation "Return the GLYPH object located at glyph index

2378

INDEX in FONT-LOADER, or NIL if no glyph is defined for that

2379

index. Despite the name, NOT the inverse of GLYPH-INDEX.")

2380

(:method (index font-loader)

2381

(let* ((cache (glyph-cache font-loader))

2382

(glyph (aref cache index)))

2383

(if glyph

2384

glyph

2385

(setf (aref cache index)

2386

(make-instance 'glyph

2387

:font-index index

2388

:font-loader font-loader))))))

2389

2390

;;;; Misc

2391

(defmethod postscript-name ((glyph glyph))

2392

(let* ((names (postscript-glyph-names (font-loader glyph)))

2393

(index (font-index glyph))

2394

(name (aref names index)))

2395

(cond (name)

2396

((slot-boundp glyph 'code-point)

2397

(setf (aref names index)

2398

(format nil "uni~4,'0X" (code-point glyph))))

2399

(t "unknown"))))

2400

2401

;;; font-loader-interface

2402

;; Interface functions for creating, initializing, and closing a FONT-LOADER

2403

;; object.

2404

(defun arrange-finalization (object stream)

2405

(flet ((quietly-close (&optional object)

2406

(declare (ignore object))

2407

(ignore-errors (close stream))))

2408

(sb-ext:finalize object #'quietly-close)))

2409

2410

(defun check-magic (magic &rest ok)

2411

(cond

2412

((member magic ok)

2413

t)

2414

((= magic (tag->number "typ1"))

2415

(error 'unsupported-format

2416

:location "font header"

2417

             :description "Old style of PostScript font housed in a sfnt wrapper not supported."

2418

:actual-value magic

2419

:expected-values ok))

2420

((= magic (tag->number "OTTO"))

2421

(error 'unsupported-format

2422

:location "font header"

2423

:description "OpenType font with PostScript outlines not supported."

2424

:actual-value magic

2425

:expected-values ok))

2426

(t

2427

(error 'bad-magic

2428

:location "font header"

2429

:expected-values ok

2430

:actual-value magic))))

2431

2432

;; FIXME: move most/all of this stuff into initialize-instance

2433

(defun open-font-loader-from-stream (input-stream &key (collection-index 0))

2434

(let ((magic (read-uint32 input-stream))

2435

(font-count))

2436

(check-magic magic #x00010000

2437

(tag->number "true")

2438

(tag->number "ttcf"))

2439

(when (= magic (tag->number "ttcf"))

2440

(let ((version (read-uint32 input-stream)))

2441

(check-version "ttc header" version #x00010000 #x00020000)

2442

(setf font-count (read-uint32 input-stream))

2443

(let* ((offset-table (make-array font-count))

2444

(dsig))

2445

(when (> collection-index font-count)

2446

(error 'unsupported-value

2447

:description "Font index out of range"

2448

:actual-value collection-index

2449

:expected-values (list font-count)))

2450

(loop for i below font-count

2451

do (setf (aref offset-table i) (read-uint32 input-stream)))

2452

(when (= version #x00020000)

2453

(let ((flag (read-uint32 input-stream))

2454

(length (read-uint32 input-stream))

2455

(offset (read-uint32 input-stream)))

2456

(list flag length offset)

2457

(when (= #x44534947 flag)

2458

(setf dsig (list length offset)))))

2459

;; seek to font offset table

2460

(file-position input-stream (aref offset-table collection-index))

2461

(let ((magic2 (read-uint32 input-stream)))

2462

(check-magic magic2 #x00010000 (tag->number "true"))))))

2463

2464

(let* ((table-count (read-uint16 input-stream))

2465

(font-loader (make-instance 'font-loader

2466

:input-stream input-stream

2467

:table-count table-count

2468

:collection-font-cont font-count

2469

:collection-font-index

2470

(when font-count

2471

collection-index))))

2472

;; skip the unused stuff:

2473

;; searchRange, entrySelector, rangeShift

2474

(read-uint16 input-stream)

2475

(read-uint16 input-stream)

2476

(read-uint16 input-stream)

2477

(loop repeat table-count

2478

for tag = (read-uint32 input-stream)

2479

for checksum = (read-uint32 input-stream)

2480

for offset = (read-uint32 input-stream)

2481

for size = (read-uint32 input-stream)

2482

do (setf (gethash tag (tables font-loader))

2483

(make-instance 'table-info

2484

:offset offset

2485

:name (number->tag tag)

2486

:size size)))

2487

(load-maxp-info font-loader)

2488

(load-head-info font-loader)

2489

(load-kern-info font-loader)

2490

(load-loca-info font-loader)

2491

(load-name-info font-loader)

2492

(load-cmap-info font-loader)

2493

(load-post-info font-loader)

2494

(load-hhea-info font-loader)

2495

(load-hmtx-info font-loader)

2496

(load-vhea-info font-loader)

2497

(load-vmtx-info font-loader)

2498

(setf (glyph-cache font-loader)

2499

(make-array (glyph-count font-loader) :initial-element nil))

2500

font-loader)))

2501

2502

(defun open-font-loader-from-file (thing &key (collection-index 0))

2503

(let ((stream (open thing

2504

:direction :input

2505

:element-type '(unsigned-byte 8))))

2506

(let ((font-loader (open-font-loader-from-stream

2507

stream :collection-index collection-index)))

2508

(arrange-finalization font-loader stream)

2509

font-loader)))

2510

2511

(defun open-font-loader (thing &key (collection-index 0))

2512

(typecase thing

2513

(font-loader

2514

(cond

2515

;; We either don't have a collection, or want same font from

2516

;; collection.

2517

((or (not (collection-font-index thing))

2518

(= collection-index (collection-font-index thing)))

2519

(unless (open-stream-p (input-stream thing))

2520

(setf (input-stream thing) (open (input-stream thing))))

2521

thing)

2522

(t

2523

(open-font-loader-from-file (input-stream thing)

2524

:collection-index collection-index))))

2525

(stream

2526

(if (open-stream-p thing)

2527

(open-font-loader-from-stream thing :collection-index collection-index)

2528

(error "~A is not an open stream" thing)))

2529

(t

2530

(open-font-loader-from-file thing :collection-index collection-index))))

2531

2532

(defun close-font-loader (loader)

2533

(close (input-stream loader)))

2534

2535

(defmacro with-font-loader ((loader file &key (collection-index 0)) &body body)

2536

`(let (,loader)

2537

(unwind-protect

2538

(progn

2539

(setf ,loader (open-font-loader ,file

2540

                                            :collection-index ,collection-index))

2541

,@body)

2542

(when ,loader

2543

(close-font-loader ,loader)))))

2544

2545

;;; Font Cache

2546

(defun ttf-pathname-p (pathname)

2547

(string-equal "ttf" (pathname-type pathname)))

2548

2549

(defvar *font-dirs*

2550

(list "/usr/share/fonts/"

2551

(namestring (merge-pathnames ".fonts/" (user-homedir-pathname))))

2552

"List of directories, which contain TrueType fonts.")

2553

2554

(defparameter *font-cache* (make-hash-table :test 'equal)

2555

"Hashmap for caching font families, subfamilies and files.")

2556

2557

;; (pushnew (xlib:font-path *display*) *font-dirs*)

2558

(defun cache-font-file (pathname)

2559

"Caches font file."

2560

(handler-case

2561

(with-font-loader (font pathname)

2562

(multiple-value-bind (hash-table exists-p)

2563

(gethash (family-name font) *font-cache*

2564

(make-hash-table :test 'equal))

2565

(setf (gethash (subfamily-name font) hash-table)

2566

pathname)

2567

(unless exists-p

2568

(setf (gethash (family-name font) *font-cache*)

2569

hash-table))))

2570

(condition () (return-from cache-font-file))))

2571

2572

(defun cache-fonts ()

2573

"Caches fonts from *font-dirs* directories."

2574

(clrhash *font-cache*)

2575

(dolist (font-dir *font-dirs*)

2576

(walk-directory font-dir (constantly t) (constantly t)

2577

(lambda (x)

2578

(dolist (f (directory-files x))

2579

(when (ttf-pathname-p f)

2580

(cache-font-file f)))))))

2581

2582

(defun get-font-families ()

2583

"Returns cached font families."

2584

(declare (special *font-cache*))

2585

(let ((result (list)))

2586

(maphash (lambda (key value)

2587

(declare (ignorable value))

2588

(push key result))

2589

*font-cache*)

2590

(nreverse result)))

2591

2592

(defun get-font-subfamilies (font-family)

2593

"Returns font subfamilies for current @var{font-family}. For e.g. regular, italic, bold, etc."

2594

(declare (special *font-cache*))

2595

(let ((result (list)))

2596

(maphash (lambda (family value)

2597

(declare (ignorable family))

2598

(when (string-equal font-family family)

2599

(maphash (lambda (subfamily pathname)

2600

(declare (ignorable pathname))

2601

(push subfamily result)) value)

2602

(return-from get-font-subfamilies

2603

(nreverse result)))) *font-cache*)

2604

(nreverse result)))

2605

2606

(defclass font ()

2607

((family :type string :initarg :family :accessor font-family :documentation "Font family.")

2608

    (subfamily :type string :initarg :subfamily :accessor font-subfamily :documentation "Font subfamily. For e.g. regular, italic, bold, bold italib.")

2609

    (size :type real :initarg :size :accessor font-size :initform 12 :documentation "Font size in points.")

2610

    (underline :type boolean :initarg :underline :initform nil :accessor font-underline :documentation "Draw line under text string.")

2611

    (strikethrough :type boolean :initarg :strikethrough :initform nil :accessor font-strikethrough :documentation "Draw strike through text string.")

2612

    (overline :type boolean :initarg :overline :initform nil :accessor font-overline :documentation "Draw line over text string.")

2613

    (background :initarg :background :initform nil :accessor font-background :documentation "Background color.")

2614

    (foreground :initarg :foreground :initform nil :accessor font-foreground :documentation "Foreground color.")

2615

(overwrite-gcontext :type boolean :initarg :overwrite-gcontext :initform nil

2616

                        :accessor font-overwrite-gcontext :documentation "Use font values for background and foreground colors.")

2617

    (antialias :type boolean :initarg :antialias :initform t :accessor font-antialias :documentation "Antialias text string.")

2618

(string-bboxes :type cache:cache :accessor font-string-bboxes

2619

:documentation "Cache for text bboxes")

2620

(string-line-bboxes :type cache:cache :accessor font-string-line-bboxes

2621

:documentation "Cache for text line bboxes")

2622

(string-alpha-maps :type cache:cache :accessor font-string-alpha-maps

2623

:documentation "Cache for text alpha maps")

2624

(string-line-alpha-maps :type cache:cache :accessor font-string-line-alpha-maps

2625

:documentation "Cache for text line alpha maps"))

2626

(:documentation "Class for representing font information."))

2627

2628

(defun check-valid-font-families (family subfamily)

2629

(when (or (null (gethash family *font-cache*))

2630

(null (gethash subfamily (gethash family *font-cache*))))

2631

(error "Font is not found: ~A ~A" family subfamily)))

2632

2633

(defmethod initialize-instance :before

2634

((instance font) &rest initargs &key family subfamily &allow-other-keys)

2635

(declare (ignorable initargs))

2636

(check-valid-font-families family subfamily))

2637

2638

(defmethod (setf font-family) :before

2639

(family (instance font))

2640

(check-valid-font-families family (font-subfamily instance)))

2641

2642

(defmethod (setf font-subfamily) :before

2643

(subfamily (instance font))

2644

(check-valid-font-families (font-family instance) subfamily))

2645

2646

(defmethod (setf font-family) :after

2647

(family (font font))

2648

(cache:cache-flush (font-string-bboxes font))

2649

(cache:cache-flush (font-string-line-bboxes font)))

2650

2651

(defmethod (setf font-subfamily) :after

2652

(subfamily (font font))

2653

(cache:cache-flush (font-string-bboxes font))

2654

(cache:cache-flush (font-string-line-bboxes font)))

2655

2656

(defmethod (setf font-size) :after (value (font font))

2657

(cache:cache-flush (font-string-bboxes font))

2658

(cache:cache-flush (font-string-line-bboxes font)))

2659

2660

(defmethod (setf font-underline) :after (value (font font))

2661

(cache:cache-flush (font-string-bboxes font)))

2662

2663

(defmethod (setf font-overline) :after (value (font font))

2664

(cache:cache-flush (font-string-bboxes font)))

2665

2666

(defgeneric font-equal (font1 font2)

2667

(:documentation "Returns t if two font objects are equal, else returns nil.")

2668

(:method ((font1 font) (font2 font))

2669

(and (string-equal (font-family font1)

2670

(font-family font2))

2671

(string-equal (font-subfamily font1)

2672

(font-subfamily font2))

2673

(= (font-size font1) (font-size font2))

2674

(eql (font-underline font1) (font-underline font2))

2675

(eql (font-strikethrough font1) (font-strikethrough font2))

2676

(eql (font-overline font1) (font-overline font2))

2677

(equal (font-background font1) (font-background font2))

2678

(equal (font-foreground font1) (font-foreground font2))

2679

(eql (font-overwrite-gcontext font1) (font-overwrite-gcontext font2))

2680

(eql (font-antialias font1) (font-antialias font2)))))

2681

2682

(defmethod equiv:equiv ((a font) (b font)) (font-equal a b))

2683

2684

(defmethod print-object ((instance font) stream)

2685

"Pretty printing font object"

2686

(with-slots (family subfamily underline strikethrough

2687

overline background foreground overwrite-gcontext

2688

antialias)

2689

instance

2690

(if *print-readably*

2691

(format stream

2692

"#.(~S '~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S)"

2693

'cl:make-instance 'font

2694

:family family :subfamily subfamily :underline underline

2695

:strikethrough strikethrough

2696

:overline overline :background background :foreground foreground

2697

:overwrite-gcontext overwrite-gcontext

2698

:antialias antialias)

2699

(format stream

2700

"#<'~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S>"

2701

'font

2702

:family family :subfamily subfamily :underline underline

2703

:strikethrough strikethrough

2704

:overline overline :background background :foreground foreground

2705

:overwrite-gcontext overwrite-gcontext

2706

:antialias antialias))))

2707

2708

;;; TTF font objects cache

2709

(defun get-font-pathname (font)

2710

(gethash (font-subfamily font) (gethash (font-family font) *font-cache*)))

2711

2712

(defvar *font-loader-cache* (make-hash-table :test 'equal))

2713

2714

(defmacro with-font ((loader font) &body body)

2715

(let ((exists-p (gensym))

2716

(font-path (gensym)))

2717

`(let ((,font-path (get-font-pathname ,font)))

2718

(multiple-value-bind (,loader ,exists-p)

2719

(gethash ,font-path *font-loader-cache*)

2720

(unless ,exists-p

2721

(setf ,loader (setf (gethash ,font-path *font-loader-cache*)

2722

(open-font-loader ,font-path))))

2723

,@body))))