| 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 Bill Chiles and Rob MacLachlan.
|
|---|
| 13 | ;;;
|
|---|
| 14 | ;;; Hemlock screen painting routines for the IBM RT running X.
|
|---|
| 15 | ;;;
|
|---|
| 16 | (in-package :hemlock-internals)
|
|---|
| 17 |
|
|---|
| 18 |
|
|---|
| 19 | ;;;; TODO
|
|---|
| 20 |
|
|---|
| 21 | ;; . do away with these bogus macros HUNK-PUT-STRING and HUNK-REPLACE-LINE-STRING.
|
|---|
| 22 |
|
|---|
| 23 | ;; . concentrate these in a single point where we draw a string, so that we
|
|---|
| 24 | ;; can easily introduce foreground and background colors for syntax
|
|---|
| 25 | ;; highlighting and neater region highlighting.
|
|---|
| 26 |
|
|---|
| 27 | ;; --GB 2003-05-22
|
|---|
| 28 |
|
|---|
| 29 | (defparameter hunk-height-limit 80 "Maximum possible height for any hunk.")
|
|---|
| 30 | (defparameter hunk-width-limit 200 "Maximum possible width for any hunk.")
|
|---|
| 31 | (defparameter hunk-top-border 2 "Clear area at beginning.")
|
|---|
| 32 | (defparameter hunk-left-border 10 "Clear area before first character.")
|
|---|
| 33 | (defparameter hunk-bottom-border 3 "Minimum Clear area at end.")
|
|---|
| 34 | (defparameter hunk-thumb-bar-bottom-border 10
|
|---|
| 35 | "Minimum Clear area at end including room for thumb bar." )
|
|---|
| 36 | (defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.")
|
|---|
| 37 | (defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.")
|
|---|
| 38 |
|
|---|
| 39 |
|
|---|
| 40 | |
|---|
| 41 |
|
|---|
| 42 | ;;;; Character translations for CLX
|
|---|
| 43 |
|
|---|
| 44 | ;;; HEMLOCK-TRANSLATE-DEFAULT.
|
|---|
| 45 | ;;;
|
|---|
| 46 | ;;; CLX glyph drawing routines allow for a character translation function. The
|
|---|
| 47 | ;;; default one takes a string (any kind) or a vector of numbers and slams them
|
|---|
| 48 | ;;; into the outgoing request buffer. When the argument is a string, it stops
|
|---|
| 49 | ;;; processing if it sees a character that is not GRAPHIC-CHAR-P. For each
|
|---|
| 50 | ;;; graphical character, the function ultimately calls CHAR-CODE.
|
|---|
| 51 | ;;;
|
|---|
| 52 | ;;; Hemlock only passes simple-strings in, and these can only contain graphical
|
|---|
| 53 | ;;; characters because of the line image builder, except for one case --
|
|---|
| 54 | ;;; *line-wrap-char* which anyone can set. Those who want to do evil things
|
|---|
| 55 | ;;; with this should know what they are doing: if they want a funny glyph as
|
|---|
| 56 | ;;; a line wrap char, then they should use CODE-CHAR on the font index. This
|
|---|
| 57 | ;;; allows the following function to translate everything with CHAR-CODE, and
|
|---|
| 58 | ;;; everybody's happy.
|
|---|
| 59 | ;;;
|
|---|
| 60 | ;;; Actually, Hemlock can passes the line string when doing random-typeout which
|
|---|
| 61 | ;;; does contain ^L's, tabs, etc. Under X10 these came out as funny glyphs,
|
|---|
| 62 | ;;; and under X11 the output is aborted without this function.
|
|---|
| 63 | ;;;
|
|---|
| 64 | (defun hemlock-translate-default (src src-start src-end font dst dst-start)
|
|---|
| 65 | (declare (simple-string src)
|
|---|
| 66 | (fixnum src-start src-end dst-start)
|
|---|
| 67 | (vector dst)
|
|---|
| 68 | (ignore font))
|
|---|
| 69 | (do ((i src-start (1+ i))
|
|---|
| 70 | (j dst-start (1+ j)))
|
|---|
| 71 | ((>= i src-end) i)
|
|---|
| 72 | (declare (fixnum i j))
|
|---|
| 73 | (setf (aref dst j) (char-code (schar src i)))))
|
|---|
| 74 |
|
|---|
| 75 | #+clx
|
|---|
| 76 | (defvar *glyph-translate-function* #'xlib:translate-default)
|
|---|
| 77 |
|
|---|
| 78 |
|
|---|
| 79 | |
|---|
| 80 |
|
|---|
| 81 | ;;;; Drawing a line.
|
|---|
| 82 |
|
|---|
| 83 | ;;;; We hack along --GB
|
|---|
| 84 | #+clx
|
|---|
| 85 | (defun find-color (window color)
|
|---|
| 86 | (let ((ht (or (getf (xlib:window-plist window) :color-hash)
|
|---|
| 87 | (setf (getf (xlib:window-plist window) :color-hash)
|
|---|
| 88 | (make-hash-table :test #'equalp)))))
|
|---|
| 89 | (or (gethash color ht)
|
|---|
| 90 | (setf (gethash color ht) (xlib:alloc-color (xlib:window-colormap window) color)))))
|
|---|
| 91 |
|
|---|
| 92 | (defparameter *color-map*
|
|---|
| 93 | #("black" "white"
|
|---|
| 94 | "black" "white"
|
|---|
| 95 | "black" "white"
|
|---|
| 96 | "black" "cornflower blue"
|
|---|
| 97 |
|
|---|
| 98 | "black" "white"
|
|---|
| 99 | "black" "white"
|
|---|
| 100 | "black" "white"
|
|---|
| 101 | "black" "white"
|
|---|
| 102 |
|
|---|
| 103 | "blue4" "white" ;8 = comments
|
|---|
| 104 | "green4" "white" ;9 = strings
|
|---|
| 105 | "red" "white" ;10 = quote
|
|---|
| 106 | "black" "white"
|
|---|
| 107 |
|
|---|
| 108 | "black" "white"
|
|---|
| 109 | "black" "white"
|
|---|
| 110 | "black" "white"
|
|---|
| 111 | "black" "white"))
|
|---|
| 112 |
|
|---|
| 113 | ;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel
|
|---|
| 114 | ;;; coordinate to draw string with font from start to end.
|
|---|
| 115 | ;;;
|
|---|
| 116 | (defmacro hunk-put-string (x y font string start end)
|
|---|
| 117 | (let ((gcontext (gensym)))
|
|---|
| 118 | `(let ((,gcontext (bitmap-hunk-gcontext hunk)))
|
|---|
| 119 | (xlib:with-gcontext (,gcontext :font ,font)
|
|---|
| 120 | (xlib:draw-image-glyphs
|
|---|
| 121 | (bitmap-hunk-xwindow hunk) ,gcontext
|
|---|
| 122 | (+ hunk-left-border (* ,x (font-family-width font-family)))
|
|---|
| 123 | (+ hunk-top-border (* ,y (font-family-height font-family))
|
|---|
| 124 | (font-family-baseline font-family))
|
|---|
| 125 | ,string :start ,start :end ,end
|
|---|
| 126 | :translate *glyph-translate-function*)))))
|
|---|
| 127 |
|
|---|
| 128 | (defun hunk-put-string* (hunk x y font-family font string start end)
|
|---|
| 129 | (let ((gcontext (bitmap-hunk-gcontext hunk))
|
|---|
| 130 | (font (svref (font-family-map font-family) font))
|
|---|
| 131 | (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2))))
|
|---|
| 132 | (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2))))))
|
|---|
| 133 | (xlib:with-gcontext (gcontext :font font
|
|---|
| 134 | :foreground fg
|
|---|
| 135 | :background bg)
|
|---|
| 136 | (xlib:draw-image-glyphs
|
|---|
| 137 | (bitmap-hunk-xwindow hunk) gcontext
|
|---|
| 138 | (+ hunk-left-border (* x (font-family-width font-family)))
|
|---|
| 139 | (+ hunk-top-border (* y (font-family-height font-family))
|
|---|
| 140 | (font-family-baseline font-family))
|
|---|
| 141 | string :start start :end end
|
|---|
| 142 | :translate *glyph-translate-function*))))
|
|---|
| 143 |
|
|---|
| 144 | ;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at
|
|---|
| 145 | ;;; which pixel coordinate to draw string with font from start to end. We draw
|
|---|
| 146 | ;;; the text on a pixmap and later blast it out to avoid line flicker since
|
|---|
| 147 | ;;; server on the RT is not very clever; it clears the entire line before
|
|---|
| 148 | ;;; drawing text.
|
|---|
| 149 |
|
|---|
| 150 | (defun hunk-replace-line-string* (hunk gcontext x y font-family font string start end)
|
|---|
| 151 | (declare (ignore y))
|
|---|
| 152 | (let ((font (svref (font-family-map font-family) font))
|
|---|
| 153 | (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2))))
|
|---|
| 154 | (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2))))))
|
|---|
| 155 | (xlib:with-gcontext (gcontext :font font
|
|---|
| 156 | :foreground fg
|
|---|
| 157 | :background bg)
|
|---|
| 158 | (xlib:draw-image-glyphs
|
|---|
| 159 | (hunk-replace-line-pixmap) gcontext
|
|---|
| 160 | (+ hunk-left-border (* x (font-family-width font-family)))
|
|---|
| 161 | (font-family-baseline font-family)
|
|---|
| 162 | string :start start :end end
|
|---|
| 163 | :translate *glyph-translate-function*))))
|
|---|
| 164 |
|
|---|
| 165 | ;;; Hunk-Write-Line -- Internal
|
|---|
| 166 | ;;;
|
|---|
| 167 | ;;; Paint a dis-line on a hunk, taking font-changes into consideration.
|
|---|
| 168 | ;;; The area of the hunk drawn on is assumed to be cleared. If supplied,
|
|---|
| 169 | ;;; the line is written at Position, and the position in the dis-line
|
|---|
| 170 | ;;; is ignored.
|
|---|
| 171 | ;;;
|
|---|
| 172 | (defun hunk-write-line (hunk dl &optional (position (dis-line-position dl)))
|
|---|
| 173 | (let* ((font-family (bitmap-hunk-font-family hunk))
|
|---|
| 174 | (chars (dis-line-chars dl))
|
|---|
| 175 | (length (dis-line-length dl)))
|
|---|
| 176 | (let ((last 0)
|
|---|
| 177 | (last-font 0))
|
|---|
| 178 | (do ((change (dis-line-font-changes dl) (font-change-next change)))
|
|---|
| 179 | ((null change)
|
|---|
| 180 | (hunk-put-string* hunk last position font-family last-font chars last length))
|
|---|
| 181 | (let ((x (font-change-x change)))
|
|---|
| 182 | (hunk-put-string* hunk last position font-family last-font chars last x)
|
|---|
| 183 | (setq last x
|
|---|
| 184 | last-font (font-change-font change)) )))))
|
|---|
| 185 |
|
|---|
| 186 |
|
|---|
| 187 | ;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS;
|
|---|
| 188 | ;;; that is, they literally clear the line, and then blast the new glyphs.
|
|---|
| 189 | ;;; We don't hack replacing the line when reverse video is turned on because
|
|---|
| 190 | ;;; this doesn't seem to work too well. Also, hacking replace line on the
|
|---|
| 191 | ;;; color Megapel display is SLOW!
|
|---|
| 192 | ;;;
|
|---|
| 193 | (defvar *hack-hunk-replace-line* t)
|
|---|
| 194 |
|
|---|
| 195 | ;;; Hunk-Replace-Line -- Internal
|
|---|
| 196 | ;;;
|
|---|
| 197 | ;;; Similar to Hunk-Write-Line, but the line need not be clear.
|
|---|
| 198 | ;;;
|
|---|
| 199 | (defun hunk-replace-line (hunk dl &optional
|
|---|
| 200 | (position (dis-line-position dl)))
|
|---|
| 201 | (if *hack-hunk-replace-line*
|
|---|
| 202 | (hunk-replace-line-on-a-pixmap hunk dl position)
|
|---|
| 203 | (old-hunk-replace-line hunk dl position)))
|
|---|
| 204 |
|
|---|
| 205 | (defun old-hunk-replace-line (hunk dl &optional (position (dis-line-position dl)))
|
|---|
| 206 | (let* ((font-family (bitmap-hunk-font-family hunk))
|
|---|
| 207 | (chars (dis-line-chars dl))
|
|---|
| 208 | (length (dis-line-length dl))
|
|---|
| 209 | (height (font-family-height font-family)) )
|
|---|
| 210 | (let ((last 0)
|
|---|
| 211 | (last-font 0))
|
|---|
| 212 | (do ((change (dis-line-font-changes dl) (font-change-next change)))
|
|---|
| 213 | ((null change)
|
|---|
| 214 | (hunk-put-string* hunk last position font-family last-font chars last length)
|
|---|
| 215 | (let ((dx (+ hunk-left-border
|
|---|
| 216 | (* (font-family-width font-family) length))))
|
|---|
| 217 | (xlib:clear-area (bitmap-hunk-xwindow hunk)
|
|---|
| 218 | :x dx
|
|---|
| 219 | :y (+ hunk-top-border (* position height))
|
|---|
| 220 | :width (- (bitmap-hunk-width hunk) dx)
|
|---|
| 221 | :height height)))
|
|---|
| 222 | (let ((x (font-change-x change)))
|
|---|
| 223 | (hunk-put-string* hunk last position font-family last-font chars last x)
|
|---|
| 224 | (setq last x last-font (font-change-font change)) )))))
|
|---|
| 225 |
|
|---|
| 226 | (defvar *hunk-replace-line-pixmap* nil)
|
|---|
| 227 |
|
|---|
| 228 | (defun hunk-replace-line-pixmap ()
|
|---|
| 229 | (if *hunk-replace-line-pixmap*
|
|---|
| 230 | *hunk-replace-line-pixmap*
|
|---|
| 231 | (let* ((hunk (window-hunk *current-window*))
|
|---|
| 232 | (gcontext (bitmap-hunk-gcontext hunk))
|
|---|
| 233 | (screen (xlib:display-default-screen
|
|---|
| 234 | (bitmap-device-display (device-hunk-device hunk))))
|
|---|
| 235 | (height (font-family-height *default-font-family*))
|
|---|
| 236 | (pixmap (xlib:create-pixmap
|
|---|
| 237 | :width (* hunk-width-limit
|
|---|
| 238 | (font-family-width *default-font-family*))
|
|---|
| 239 | :height height :depth (xlib:screen-root-depth screen)
|
|---|
| 240 | :drawable (xlib:screen-root screen))))
|
|---|
| 241 | (xlib:with-gcontext (gcontext :function boole-1
|
|---|
| 242 | :foreground *default-background-pixel*)
|
|---|
| 243 | (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t))
|
|---|
| 244 | (setf *hunk-replace-line-pixmap* pixmap))))
|
|---|
| 245 |
|
|---|
| 246 | (defun hunk-replace-line-on-a-pixmap (hunk dl position)
|
|---|
| 247 | (let* ((font-family (bitmap-hunk-font-family hunk))
|
|---|
| 248 | (chars (dis-line-chars dl))
|
|---|
| 249 | (length (dis-line-length dl))
|
|---|
| 250 | (height (font-family-height font-family))
|
|---|
| 251 | (last 0)
|
|---|
| 252 | (last-font 0)
|
|---|
| 253 | (gcontext (bitmap-hunk-gcontext hunk)))
|
|---|
| 254 | (do ((change (dis-line-font-changes dl) (font-change-next change)))
|
|---|
| 255 | ((null change)
|
|---|
| 256 | (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last length)
|
|---|
| 257 | (let* ((dx (+ hunk-left-border
|
|---|
| 258 | (* (font-family-width font-family) length)))
|
|---|
| 259 | (dy (+ hunk-top-border (* position height)))
|
|---|
| 260 | (xwin (bitmap-hunk-xwindow hunk)))
|
|---|
| 261 | (xlib:with-gcontext (gcontext :exposures nil)
|
|---|
| 262 | (xlib:copy-area (hunk-replace-line-pixmap) gcontext
|
|---|
| 263 | 0 0 dx height xwin 0 dy))
|
|---|
| 264 | (xlib:clear-area xwin :x dx :y dy
|
|---|
| 265 | :width (- (bitmap-hunk-width hunk) dx)
|
|---|
| 266 | :height height)))
|
|---|
| 267 | (let ((x (font-change-x change)))
|
|---|
| 268 | (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last x)
|
|---|
| 269 | (setq last x last-font (font-change-font change))))))
|
|---|
| 270 |
|
|---|
| 271 |
|
|---|
| 272 | ;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground
|
|---|
| 273 | ;;; color, so the initial bits where no characters go also is highlighted.
|
|---|
| 274 | ;;; Then the text is drawn background on foreground (hightlighted). This
|
|---|
| 275 | ;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil;
|
|---|
| 276 | ;;; that is, there is a modeline. This function should assume the gcontext's
|
|---|
| 277 | ;;; font is the default font of the hunk. We must LET bind the foreground and
|
|---|
| 278 | ;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious
|
|---|
| 279 | ;;; or incorrect implementation.
|
|---|
| 280 | ;;;
|
|---|
| 281 | (defun hunk-replace-modeline (hunk)
|
|---|
| 282 | (let* ((dl (bitmap-hunk-modeline-dis-line hunk))
|
|---|
| 283 | (font-family (bitmap-hunk-font-family hunk))
|
|---|
| 284 | (default-font (svref (font-family-map font-family) 0))
|
|---|
| 285 | (modeline-pos (bitmap-hunk-modeline-pos hunk))
|
|---|
| 286 | (xwindow (bitmap-hunk-xwindow hunk))
|
|---|
| 287 | (gcontext (bitmap-hunk-gcontext hunk)))
|
|---|
| 288 | (xlib:draw-rectangle xwindow gcontext 0 modeline-pos
|
|---|
| 289 | (bitmap-hunk-width hunk)
|
|---|
| 290 | (+ hunk-modeline-top hunk-modeline-bottom
|
|---|
| 291 | (font-family-height font-family))
|
|---|
| 292 | t)
|
|---|
| 293 | (xlib:with-gcontext (gcontext :foreground
|
|---|
| 294 | (xlib:gcontext-background gcontext)
|
|---|
| 295 | :background
|
|---|
| 296 | (xlib:gcontext-foreground gcontext)
|
|---|
| 297 | :font default-font)
|
|---|
| 298 | (xlib:draw-image-glyphs xwindow gcontext hunk-left-border
|
|---|
| 299 | (+ modeline-pos hunk-modeline-top
|
|---|
| 300 | (font-family-baseline font-family))
|
|---|
| 301 | (dis-line-chars dl)
|
|---|
| 302 | :end (dis-line-length dl)
|
|---|
| 303 | :translate *glyph-translate-function*))))
|
|---|
| 304 |
|
|---|
| 305 | |
|---|
| 306 |
|
|---|
| 307 | ;;;; Cursor/Border color manipulation.
|
|---|
| 308 |
|
|---|
| 309 | ;;; *hemlock-listener* is set to t by default because we can't know from X
|
|---|
| 310 | ;;; whether we come up with the pointer in our window. There is no initial
|
|---|
| 311 | ;;; :enter-window event. Defaulting this to nil causes the cursor to be hollow
|
|---|
| 312 | ;;; when the window comes up under the mouse, and you have to know how to fix
|
|---|
| 313 | ;;; it. Defaulting it to t causes the cursor to always come up full, as if
|
|---|
| 314 | ;;; Hemlock is the X listener, but this recovers naturally as you move into the
|
|---|
| 315 | ;;; window. This also coincides with Hemlock's border coming up highlighted,
|
|---|
| 316 | ;;; even when Hemlock is not the listener.
|
|---|
| 317 | ;;;
|
|---|
| 318 | (defvar *hemlock-listener* t
|
|---|
| 319 | "Highlight border when the cursor is dropped and Hemlock can receive input.")
|
|---|
| 320 | (defvar *current-highlighted-border* nil
|
|---|
| 321 | "When non-nil, the bitmap-hunk with the highlighted border.")
|
|---|
| 322 |
|
|---|
| 323 | (defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.")
|
|---|
| 324 | (defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.")
|
|---|
| 325 | (defvar *cursor-hunk* nil "Hunk the cursor is displayed on.")
|
|---|
| 326 | (defvar *cursor-dropped* nil) ; True if the cursor is currently displayed.
|
|---|
| 327 |
|
|---|
| 328 | ;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk.
|
|---|
| 329 | ;;; If the cursor is currently displayed somewhere, then lift it, and display
|
|---|
| 330 | ;;; it at its new location.
|
|---|
| 331 | ;;;
|
|---|
| 332 | (defun hunk-show-cursor (hunk x y)
|
|---|
| 333 | (unless (and (= x *hunk-cursor-x*)
|
|---|
| 334 | (= y *hunk-cursor-y*)
|
|---|
| 335 | (eq hunk *cursor-hunk*))
|
|---|
| 336 | (let ((cursor-down *cursor-dropped*))
|
|---|
| 337 | (when cursor-down (lift-cursor))
|
|---|
| 338 | (setf *hunk-cursor-x* x)
|
|---|
| 339 | (setf *hunk-cursor-y* y)
|
|---|
| 340 | (setf *cursor-hunk* hunk)
|
|---|
| 341 | (when cursor-down (drop-cursor)))))
|
|---|
| 342 |
|
|---|
| 343 | ;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay. We
|
|---|
| 344 | ;;; show a cursor and highlight the listening window's border when waiting
|
|---|
| 345 | ;;; for input.
|
|---|
| 346 | ;;;
|
|---|
| 347 | (defun frob-cursor (on)
|
|---|
| 348 | (if on (drop-cursor) (lift-cursor)))
|
|---|
| 349 |
|
|---|
| 350 | (declaim (special *default-border-pixmap* *highlight-border-pixmap*))
|
|---|
| 351 |
|
|---|
| 352 | ;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR
|
|---|
| 353 | ;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION
|
|---|
| 354 | ;;; and SMART-WINDOW-REDISPLAY). When the cursor is being dropped, since
|
|---|
| 355 | ;;; this means Hemlock is listening in the *cursor-hunk*, make sure the
|
|---|
| 356 | ;;; border of the window is highlighted as well.
|
|---|
| 357 | ;;;
|
|---|
| 358 | (defun drop-cursor ()
|
|---|
| 359 | (unless *cursor-dropped*
|
|---|
| 360 | (unless *hemlock-listener* (cursor-invert-center))
|
|---|
| 361 | (cursor-invert)
|
|---|
| 362 | (when *hemlock-listener*
|
|---|
| 363 | (cond (*current-highlighted-border*
|
|---|
| 364 | (unless (eq *current-highlighted-border* *cursor-hunk*)
|
|---|
| 365 | (setf (xlib:window-border
|
|---|
| 366 | (window-group-xparent
|
|---|
| 367 | (bitmap-hunk-window-group *current-highlighted-border*)))
|
|---|
| 368 | *default-border-pixmap*)
|
|---|
| 369 | (setf (xlib:window-border
|
|---|
| 370 | (window-group-xparent
|
|---|
| 371 | (bitmap-hunk-window-group *cursor-hunk*)))
|
|---|
| 372 | *highlight-border-pixmap*)
|
|---|
| 373 | ;; For complete gratuitous pseudo-generality, should force
|
|---|
| 374 | ;; output on *current-highlighted-border* device too.
|
|---|
| 375 | (xlib:display-force-output
|
|---|
| 376 | (bitmap-device-display (device-hunk-device *cursor-hunk*)))))
|
|---|
| 377 | (t (setf (xlib:window-border
|
|---|
| 378 | (window-group-xparent
|
|---|
| 379 | (bitmap-hunk-window-group *cursor-hunk*)))
|
|---|
| 380 | *highlight-border-pixmap*)
|
|---|
| 381 | (xlib:display-force-output
|
|---|
| 382 | (bitmap-device-display (device-hunk-device *cursor-hunk*)))))
|
|---|
| 383 | (setf *current-highlighted-border* *cursor-hunk*))
|
|---|
| 384 | (setq *cursor-dropped* t)))
|
|---|
| 385 |
|
|---|
| 386 | ;;;
|
|---|
| 387 | (defun lift-cursor ()
|
|---|
| 388 | (when *cursor-dropped*
|
|---|
| 389 | (unless *hemlock-listener* (cursor-invert-center))
|
|---|
| 390 | (cursor-invert)
|
|---|
| 391 | (setq *cursor-dropped* nil)))
|
|---|
| 392 |
|
|---|
| 393 |
|
|---|
| 394 | (defun cursor-invert-center ()
|
|---|
| 395 | (let ((family (bitmap-hunk-font-family *cursor-hunk*))
|
|---|
| 396 | (gcontext (bitmap-hunk-gcontext *cursor-hunk*)))
|
|---|
| 397 | (xlib:with-gcontext (gcontext :function boole-xor
|
|---|
| 398 | :foreground *foreground-background-xor*)
|
|---|
| 399 | (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*)
|
|---|
| 400 | gcontext
|
|---|
| 401 | (+ hunk-left-border
|
|---|
| 402 | (* *hunk-cursor-x* (font-family-width family))
|
|---|
| 403 | (font-family-cursor-x-offset family)
|
|---|
| 404 | 1)
|
|---|
| 405 | (+ hunk-top-border
|
|---|
| 406 | (* *hunk-cursor-y* (font-family-height family))
|
|---|
| 407 | (font-family-cursor-y-offset family)
|
|---|
| 408 | 1)
|
|---|
| 409 | (- (font-family-cursor-width family) 2)
|
|---|
| 410 | (- (font-family-cursor-height family) 2)
|
|---|
| 411 | t)))
|
|---|
| 412 | (xlib:display-force-output
|
|---|
| 413 | (bitmap-device-display (device-hunk-device *cursor-hunk*))))
|
|---|
| 414 |
|
|---|
| 415 | (defun cursor-invert ()
|
|---|
| 416 | (let ((family (bitmap-hunk-font-family *cursor-hunk*))
|
|---|
| 417 | (gcontext (bitmap-hunk-gcontext *cursor-hunk*)))
|
|---|
| 418 | (xlib:with-gcontext (gcontext :function boole-xor
|
|---|
| 419 | :foreground *foreground-background-xor*)
|
|---|
| 420 | (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*)
|
|---|
| 421 | gcontext
|
|---|
| 422 | (+ hunk-left-border
|
|---|
| 423 | (* *hunk-cursor-x* (font-family-width family))
|
|---|
| 424 | (font-family-cursor-x-offset family))
|
|---|
| 425 | (+ hunk-top-border
|
|---|
| 426 | (* *hunk-cursor-y* (font-family-height family))
|
|---|
| 427 | (font-family-cursor-y-offset family))
|
|---|
| 428 | (font-family-cursor-width family)
|
|---|
| 429 | (font-family-cursor-height family)
|
|---|
| 430 | t)))
|
|---|
| 431 | (xlib:display-force-output
|
|---|
| 432 | (bitmap-device-display (device-hunk-device *cursor-hunk*))))
|
|---|
| 433 |
|
|---|
| 434 |
|
|---|
| 435 | |
|---|
| 436 |
|
|---|
| 437 | ;;;; Clearing and Copying Lines.
|
|---|
| 438 |
|
|---|
| 439 | (defun hunk-clear-lines (hunk start count)
|
|---|
| 440 | (let ((height (font-family-height (bitmap-hunk-font-family hunk))))
|
|---|
| 441 | (xlib:clear-area (bitmap-hunk-xwindow hunk)
|
|---|
| 442 | :x 0 :y (+ hunk-top-border (* start height))
|
|---|
| 443 | :width (bitmap-hunk-width hunk)
|
|---|
| 444 | :height (* count height))))
|
|---|
| 445 |
|
|---|
| 446 | (defun hunk-copy-lines (hunk src dst count)
|
|---|
| 447 | (let ((height (font-family-height (bitmap-hunk-font-family hunk)))
|
|---|
| 448 | (xwindow (bitmap-hunk-xwindow hunk)))
|
|---|
| 449 | (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk)
|
|---|
| 450 | 0 (+ hunk-top-border (* src height))
|
|---|
| 451 | (bitmap-hunk-width hunk) (* height count)
|
|---|
| 452 | xwindow 0 (+ hunk-top-border (* dst height)))))
|
|---|
| 453 |
|
|---|
| 454 |
|
|---|
| 455 | |
|---|
| 456 |
|
|---|
| 457 | ;;;; Drawing bottom border meter.
|
|---|
| 458 |
|
|---|
| 459 | ;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs. The LOGAND
|
|---|
| 460 | ;;; calls in the loop are testing for no remainder when dividing by 8, 4,
|
|---|
| 461 | ;;; and other. This lets us quickly draw longer notches at tab stops and
|
|---|
| 462 | ;;; half way in between. This function assumes that
|
|---|
| 463 | ;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a
|
|---|
| 464 | ;;; modeline.
|
|---|
| 465 | ;;;
|
|---|
| 466 | (defun hunk-draw-bottom-border (hunk)
|
|---|
| 467 | (when (bitmap-hunk-thumb-bar-p hunk)
|
|---|
| 468 | (let* ((xwindow (bitmap-hunk-xwindow hunk))
|
|---|
| 469 | (gcontext (bitmap-hunk-gcontext hunk))
|
|---|
| 470 | (modeline-pos (bitmap-hunk-modeline-pos hunk))
|
|---|
| 471 | (font-family (bitmap-hunk-font-family hunk))
|
|---|
| 472 | (font-width (font-family-width font-family)))
|
|---|
| 473 | (xlib:clear-area xwindow :x 0 :y (- modeline-pos
|
|---|
| 474 | hunk-thumb-bar-bottom-border)
|
|---|
| 475 | :width (bitmap-hunk-width hunk)
|
|---|
| 476 | :height hunk-bottom-border)
|
|---|
| 477 | (let ((x (+ hunk-left-border (ash font-width -1)))
|
|---|
| 478 | (y7 (- modeline-pos 7))
|
|---|
| 479 | (y5 (- modeline-pos 5))
|
|---|
| 480 | (y3 (- modeline-pos 3)))
|
|---|
| 481 | (dotimes (i (bitmap-hunk-char-width hunk))
|
|---|
| 482 | (cond ((zerop (logand i 7))
|
|---|
| 483 | (xlib:draw-rectangle xwindow gcontext
|
|---|
| 484 | x y7 (if (= i 80) 2 1) 7 t))
|
|---|
| 485 | ((zerop (logand i 3))
|
|---|
| 486 | (xlib:draw-rectangle xwindow gcontext x y5 1 5 t))
|
|---|
| 487 | (t
|
|---|
| 488 | (xlib:draw-rectangle xwindow gcontext x y3 1 3 t)))
|
|---|
| 489 | (incf x font-width))))))
|
|---|
| 490 |
|
|---|
| 491 | ;; $Log$
|
|---|
| 492 | ;; Revision 1.1 2003/10/19 08:57:15 gb
|
|---|
| 493 | ;; Initial revision
|
|---|
| 494 | ;;
|
|---|
| 495 | ;; Revision 1.1.2.2 2003/09/18 13:40:16 gb
|
|---|
| 496 | ;; Conditionalize for #-CLX, a little more.
|
|---|
| 497 | ;;
|
|---|
| 498 | ;; Revision 1.1.2.1 2003/08/10 19:11:27 gb
|
|---|
| 499 | ;; New files, imported from upstream CVS as of 03/08/09.
|
|---|
| 500 | ;;
|
|---|
| 501 | ;; Revision 1.4 2003/08/05 19:54:17 gilbert
|
|---|
| 502 | ;; - did away with some macros
|
|---|
| 503 | ;; - invested in a left margin for added readability of hemlock frames.
|
|---|
| 504 | ;;
|
|---|
