source: trunk/ccl/hemlock/src/font.lisp @ 799

Last change on this file since 799 was 799, checked in by gb, 15 years ago

Partial integration with new font-region stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.7 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Written by Rob MacLachlan
13;;; Modified by Bill Chiles toward Hemlock running under X.
14;;;
15;;;    This file contains various functions that make up the user interface to
16;;; fonts.
17;;;
18
19(in-package :hemlock-internals)
20
21;;; Default-font used to be in the above list, but when I cleaned up the way
22;;; Hemlock compiles, a name conflict occurred because "Default Font" is a
23;;; Hemlock variable.  It is now exported by the export list in rompsite.lisp.
24
25(defvar *default-font-family* (make-font-family))
26
27
28
29;;;; Creating, Deleting, and Moving.
30
31(defun new-font-region (buffer start-mark end-mark  font)
32  (let* ((start-line (mark-line start-mark))
33         (end-line (mark-line end-mark))
34         (font-start (internal-make-font-mark start-line
35                                              (mark-charpos start-mark)
36                                              :right-inserting
37                                              font))
38         (font-end (internal-make-font-mark end-line
39                                              (mark-charpos end-mark)
40                                              :right-inserting
41                                              font))
42         (region (internal-make-font-region font-start font-end)))
43    (setf (font-mark-region font-start) region
44          (font-mark-region font-end) region)
45    (push font-start (line-marks start-line))
46    (push font-end (line-marks end-line))
47    (add-buffer-font-region buffer region)
48    (buffer-note-font-change buffer region)
49    region))
50
51
52
53
54
55(defun font-mark (line charpos font &optional (kind :right-inserting))
56  "Returns a font on line at charpos with font.  Font marks must be permanent
57   marks."
58  (unless (or (eq kind :right-inserting) (eq kind :left-inserting))
59    (error "A Font-Mark must be :left-inserting or :right-inserting."))
60  (unless (and (>= font 0) (< font font-map-size))
61    (error "Font number ~S out of range." font))
62  (let ((new (internal-make-font-mark line charpos kind font)))
63    (new-font-mark new line)
64    (push new (line-marks line))
65    (incf (line-font-mark-count line))
66    new))
67
68(defun delete-font-mark (font-mark)
69  "Deletes a font mark."
70  (check-type font-mark font-mark)
71  (let ((line (mark-line font-mark)))
72    (when line
73      (setf (line-marks line) (delq font-mark (line-marks line)))
74      (decf (line-font-mark-count line))
75      (nuke-font-mark font-mark line)
76      (setf (mark-line font-mark) nil))))
77
78(defun delete-line-font-marks (line)
79  "Deletes all font marks on line."
80  (dolist (m (line-marks line))
81    (when (fast-font-mark-p m)
82      (delete-font-mark m))))
83
84(defun move-font-mark (font-mark new-position)
85  "Moves font mark font-mark to location of mark new-position."
86  (check-type font-mark font-mark)
87  (let ((old-line (mark-line font-mark))
88        (new-line (mark-line new-position)))
89    (nuke-font-mark font-mark old-line)
90    (move-mark font-mark new-position)
91    (new-font-mark font-mark new-line)
92    font-mark))
93
94(defun nuke-font-mark (mark line)
95  (new-font-mark mark line))
96
97(defun new-font-mark (mark line)
98  (declare (ignore mark line))
99)
100
101
102
103;;;; Referencing and setting font ids.
104
105#+clx
106(progn
107(defun window-font (window font)
108  "Returns a font id for window and font."
109  (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font))
110
111(defun %set-window-font (window font font-object)
112  (unless (and (>= font 0) (< font font-map-size))
113    (error "Font number ~S out of range." font))
114  (setf (bitmap-hunk-trashed (window-hunk window)) :font-change)
115  (let ((family (bitmap-hunk-font-family (window-hunk window))))
116    (when (eq family *default-font-family*)
117      (setq family (copy-font-family family))
118      (setf (font-family-map family) (copy-seq (font-family-map family)))
119      (setf (bitmap-hunk-font-family (window-hunk window)) family))
120    (setf (svref (font-family-map family) font) font-object)))
121
122(defun default-font (font)
123  "Returns the font id for font out of the default font family."
124  (svref (font-family-map *default-font-family*) font))
125
126(defun %set-default-font (font font-object)
127  (unless (and (>= font 0) (< font font-map-size))
128    (error "Font number ~S out of range." font))
129  (dolist (w *window-list*)
130    (when (eq (bitmap-hunk-font-family (window-hunk w)) *default-font-family*)
131      (setf (bitmap-hunk-trashed (window-hunk w)) :font-change)))
132  (setf (svref (font-family-map *default-font-family*) font) font-object))
133)
Note: See TracBrowser for help on using the repository browser.