From 7878b1eec83ebeac357447ce86a7d3e091ec1f38 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Wed, 7 Apr 1993 09:07:31 +0000 Subject: [PATCH] Makefile.generic OLIT to use difference X libraries Makefile.sun4 OLIT to use difference X libraries Makefile.sun4.motif-1.1.4 OLIT to use difference X libraries clim/accept-values.lisp graphical accept-values-command-buttons clim/graph-formatting.lisp Removed assertion clim/graphics-recording.lisp Comment clim/incremental-redisplay.lisp Nothing changed clim/interactive-defs.lisp Moved methods to interactive-protocol.lisp clim/interactive-protocol.lisp Added methods from interactive-defs.lisp. They are specialized on the stream clim/recording-protocol.lisp Fixed incremental redisplay problem involve :parent argument. We now look in the parent for old-children climtoys/ib.lisp Implemented multiple selections. hbox/vbox adopt all selected widgets as their children removed crap climtoys/pi.lisp presentation-inspect calls winspect on presentation demo/bitmap-editor.lisp Nothing demo/browser.lisp Redid browser layout. Removed option not to merge duplicates since that breaks redisplay. Removed call to redisplay-frame-pane inside the avv display function since that interacts with the original stream problem to create empty output records. hpgl/hpgl-port.lisp Combined duplicated initialize-instance methods test/test-suite.lisp Nothing tk/xlib.lisp Fixed compose-status typo tk-silica/xm-gadgets.lisp Correct computation of pixmap label size tk-silica/xm-silica.lisp Put focus policy back to pointer tk-silica/xt-graphics.lisp Sped up rotated text by caching rotated strings tk-silica/xt-silica.lisp Added rotated string cache to xt-port --- Makefile.generic | 10 +- clim/accept-values.lisp | 11 +- clim/graph-formatting.lisp | 3 +- clim/incremental-redisplay.lisp | 53 +++--- demo/browser.lisp | 39 +++-- test/test-suite.lisp | 16 +- tk-silica/xm-gadgets.lisp | 23 ++- tk-silica/xm-silica.lisp | 4 +- tk-silica/xt-graphics.lisp | 291 +++++++++++++++++++++----------- tk-silica/xt-silica.lisp | 3 +- 10 files changed, 295 insertions(+), 158 deletions(-) diff --git a/Makefile.generic b/Makefile.generic index 19fa82c6..805584e6 100644 --- a/Makefile.generic +++ b/Makefile.generic @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.generic,v 1.5 93/04/02 13:35:41 cer Exp $ +# $fiHeader: Makefile.generic,v 1.6 93/04/02 18:40:38 cer Exp $ # # Makefile.generic for CLIM 2.0 # @@ -38,8 +38,8 @@ compile-ol: $(OPENLOOK_OBJS) FORCE (lambda () \ (setq *compile-print* $(COMPILE_PRINT)) \ (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \ - (setq sys::*libxt-pathname* \"$(XTLIB)\") \ - (setq sys::*libx11-pathname* \"$(XLIB)\") \ + (setq sys::*libxt-pathname* \"$(OLXTLIB)\") \ + (setq sys::*libx11-pathname* \"$(OLXLIB)\") \ (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ (setq *ignore-package-name-case* t) \ (set-case-mode :case-insensitive-lower) \ @@ -146,8 +146,8 @@ clim-xm: FORCE $(MOTIF_OBJS) clim-ol: FORCE $(OPENLOOK_OBJS) -$(RM) -f $(CLIMOL) $(ECHO) " \ - (setq sys::*libxt-pathname* \"$(XTLIB)\") \ - (setq sys::*libx11-pathname* \"$(XLIB)\") \ + (setq sys::*libxt-pathname* \"$(OLXTLIB)\") \ + (setq sys::*libx11-pathname* \"$(OLXLIB)\") \ (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ (load \"misc/dev-load-1.lisp\") \ (load-it 'openlook-clim) \ diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index b0a3ea46..926bec3d 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.57 93/03/31 10:38:30 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.58 93/04/02 13:35:55 cer Exp $ (in-package :clim-internals) @@ -1376,9 +1376,14 @@ :label (if (stringp prompt) prompt - (pixmap-from-menu-item stream + ;;-- Does this suck or what??? + ;;-- If you do a + ;;surrounding-output-with-border without + ;;this write-string output does not get bordered. + (let ((*original-stream* nil)) + (pixmap-from-menu-item stream prompt #'funcall - nil))))))) + nil)))))))) diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index 4bcaeaf9..5049ae6a 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graph-formatting.lisp,v 1.26 93/03/31 10:38:37 cer Exp $ +;; $fiHeader: graph-formatting.lisp,v 1.27 93/04/02 18:40:58 cer Exp $ (in-package :clim-internals) @@ -812,7 +812,6 @@ circular graphs without accounting for this case. (setf (generation-start-depth descr) depth-so-far) (incf depth-so-far (+ generation-separation (generation-depth descr)))) ;; Determine breadth-spacing - (assert broadest-gen-descr) (incf max-gen-breadth (* within-generation-separation (generation-size broadest-gen-descr))) (loop for descr in generation-descriptors do diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp index e4f1536b..d0443ce9 100644 --- a/clim/incremental-redisplay.lisp +++ b/clim/incremental-redisplay.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: incremental-redisplay.lisp,v 1.16 93/03/19 09:43:33 cer Exp $ +;; $fiHeader: incremental-redisplay.lisp,v 1.17 93/03/31 10:38:40 cer Exp $ (in-package :clim-internals) @@ -172,24 +172,32 @@ (apply #'match-output-records candidate initargs)))) (let ((elts-to-find (when use-old-children (output-record-old-children record)))) (if use-old-children + ;; Bugger me, you learn several new things about + ;; incremental redisplay every day. This code does not do a + ;; full search of the old-children but rather just looks at + ;; the first two. I suppose its reasonable since things + ;; normally get created in the same order again. However, in + ;; the case of the grapher things tend to get created in a + ;; more random order causing this to fail unnecessarily. (let ((found-record - (if unique-id - (find-with-test unique-id elts-to-find - #'output-record-unique-id id-test) - ;; UNIQUE-ID can be NIL when we are coming through - ;; INVOKE-WITH-NEW-OUTPUT-RECORD to create new records - (or (and (do-match (first elts-to-find)) (first elts-to-find)) - (let ((candidate (second elts-to-find))) - (and (do-match candidate) - ;; assume the first one was deleted, and - ;; therefore we don't want to match - ;; against it anymore. - ;; If they want better performance, they - ;; should use UID's. - (setf (output-record-old-children record) - (nconc (rest elts-to-find) - (list (first elts-to-find)))) - candidate)))))) + (if unique-id + (find-with-test unique-id elts-to-find + #'output-record-unique-id id-test) + ;; UNIQUE-ID can be NIL when we are coming through + ;; INVOKE-WITH-NEW-OUTPUT-RECORD to create new records + (or (and (do-match (first elts-to-find)) + (first elts-to-find)) + (let ((candidate (second elts-to-find))) + (and (do-match candidate) + ;; assume the first one was deleted, and + ;; therefore we don't want to match + ;; against it anymore. + ;; If they want better performance, they + ;; should use UID's. + (setf (output-record-old-children record) + (nconc (rest elts-to-find) + (list (first elts-to-find)))) + candidate)))))) (when found-record (setf (output-record-old-children record) (delete found-record (output-record-old-children record))) @@ -438,6 +446,7 @@ (old-x-offset (coordinate 0)) (old-y-offset (coordinate 0))) (declare (type coordinate x-offset y-offset old-x-offset old-y-offset)) (declare (values erases moves draws erase-overlapping move-overlapping)) + #+ignore (when (eq record wt::*c*) (break "found it")) (let ((erases nil) (moves nil) (draws nil) @@ -649,7 +658,7 @@ (with-bounding-rectangle* (left top right bottom) rectangle (translate-coordinates xoff yoff left top right bottom) (draw-rectangle* stream left top right bottom - :ink +background-ink+ :filled t) + :ink #+ignore +red+ +background-ink+ :filled t) #+ignore (break "erase ~S" (list left top right bottom)))) (replay-record (record stream region) @@ -932,6 +941,12 @@ ;; is if another, more deeply nested output record, was moved ;; from somewhere in the hierarchy that was >not< erased. In that ;; case, we could just bitblt, but we won't detect that anymore. + + ;;--- I dont understand how this is right + ;;--- since we have to do the erase first + ;;--- Anyway things are screwed up when the parent has changed + ;;--- Since we dont know where things are. + ((and old-parent (not (eq (output-record-parent record) old-parent)) (not (eq (output-record-generation-tick old-parent) *generation-tick*))) diff --git a/demo/browser.lisp b/demo/browser.lisp index c48be0a6..747c51ef 100644 --- a/demo/browser.lisp +++ b/demo/browser.lisp @@ -3,7 +3,7 @@ ;;; Simple extensible browser ;;; Scott McKay -;; $fiHeader: browser.lisp,v 1.18 93/01/18 13:55:04 cer Exp $ +;; $fiHeader: browser.lisp,v 1.19 93/03/19 09:44:09 cer Exp $ (in-package :clim-browser) @@ -747,18 +747,20 @@ :end-of-line-action :allow) (interactor :interactor :height '(5 :line)) (control-panel :accept-values - :height :compute + :height :compute :width :compute + :max-height :compute :max-width :compute + :scroll-bars nil :display-function '(accept-values-pane-displayer - :displayer accept-call-graph-options))) + :align-prompts t + :displayer accept-call-graph-options))) (:layouts (default (vertically () - (3/4 graph) - (:fill - (horizontally () - (1/2 interactor) - (:fill control-panel))))))) + (:fill graph) + (horizontally () + (:fill interactor) + control-panel))))) #+genera (define-genera-application browser :select-key #\) @@ -1027,16 +1029,17 @@ (with-slots (browser-type browser-subtype tree-depth merge-duplicate-nodes auto-snapshot browser-options root-nodes root-node-maker all-nodes) browser - (flet ((accept (type default prompt query-id) - (fresh-line stream) - (accept type + (flet ((accept (type default prompt query-id &rest options) + (apply #'accept type :stream stream :default default :query-identifier query-id - :prompt prompt))) + :prompt prompt + options))) (declare (dynamic-extent #'accept)) (multiple-value-bind (new-type ignore type-changed) (accept `(member ,@*browser-types*) (or browser-type (first *browser-types*)) - "Browser type" 'type) + "Browser type" 'type + :view '(radio-box-view :columns 2)) (declare (ignore ignore)) (let* ((sub-ptype (browser-type-subtypes new-type)) @@ -1046,10 +1049,8 @@ "Browser subtype" 'subtype)) (new-depth (accept '(integer 1 10) tree-depth - "Starting depth" 'depth)) - (new-merge - (accept 'boolean merge-duplicate-nodes - "Merge duplicate nodes" 'merge)) + "Starting depth" 'depth :view + '(text-field-view :width (4 :character)))) (new-auto-snapshot (accept 'boolean auto-snapshot "Automatic snapshots" 'auto-snapshot))) @@ -1057,7 +1058,6 @@ (when additional-dialog (funcall additional-dialog browser stream))) (setq tree-depth new-depth - merge-duplicate-nodes new-merge auto-snapshot new-auto-snapshot) (when (or (not (eql new-type browser-type)) (not (eql new-subtype browser-subtype))) @@ -1072,8 +1072,7 @@ ;; ALL-NODES and ROOT-NODES must not be EQ lists... (setq all-nodes (copy-list root-nodes)))) ;; Regenerate and redisplay the call graph - (generate-call-graph browser root-nodes) - (redisplay-frame-pane *application-frame* 'graph :force-p t))))))) + (generate-call-graph browser root-nodes))))))) ;;; Browser commands diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 9574d408..644b75f2 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.56 93/03/25 15:40:54 colin Exp $ +;; $fiHeader: test-suite.lisp,v 1.57 93/03/31 10:39:51 cer Exp $ (in-package :clim-user) @@ -708,15 +708,23 @@ people, shall not perish from the earth. (draw-text* stream "Some fox jumped over something" 200 200 :towards-x 0 :towards-y 200 :text-style '(nil :bold :large))) - (with-output-as-presentation (stream 4 'form) (draw-text* stream "Some fox jumped over something" 200 200 :towards-x 200 :towards-y 0 :text-style '(nil :bold :small))) - (do ((x 300 (+ x 20))) + (do* ((x 300 (+ x 20)) + (all-packages (list-all-packages))) ((> x 1000)) (with-output-as-presentation (stream 4 'form) - (draw-text* stream "Dont be silly in the City." x 200 + (draw-text* stream + (let ((r "")) + (dotimes (i 5 r) + (setq r (concatenate 'string + r " " (package-name (nth (random + (length + all-packages)) + all-packages)))))) + x 200 :towards-x x :towards-y 0))))) (define-test (negative-extent graphics) (stream) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index e598bb26..bc84c504 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.69 93/03/31 10:40:20 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.70 93/04/02 13:37:26 cer Exp $ (in-package :xm-silica) @@ -172,8 +172,8 @@ :height (process-height-specification sheet `(1 :line)))) (tk::pixmap (make-space-requirement - :width (xt::pixmap-width label) - :height (xt::pixmap-height label)))))) + :width (+ (xt::pixmap-width label) (text-gadget-margin-width sheet)) + :height (+ (xt::pixmap-height label) (text-gadget-margin-height sheet))))))) ;;; Push button @@ -575,10 +575,14 @@ (first width)) (string (length width))))) (multiple-value-bind (font-list margin highlight shadow) - (tk::get-values (sheet-direct-mirror sheet) - :font-list :margin-width :highlight-thickness :shadow-thickness) - (let ((font-width (font-list-max-width-and-height font-list))) - (+ (* 2 (+ margin highlight shadow)) (* font-width chars)))))) + (tk::get-values (sheet-direct-mirror sheet) :font-list + :margin-width :highlight-thickness :shadow-thickness) + (+ (* 2 (+ margin highlight shadow)) (* (font-list-max-width-and-height font-list) chars))))) + +(defun text-gadget-margin-width (sheet) + (multiple-value-bind (margin highlight shadow) + (tk::get-values (sheet-direct-mirror sheet) :margin-width :highlight-thickness :shadow-thickness) + (+ (* 2 (+ margin highlight shadow))))) (defun font-list-max-width-and-height (font-list) (let* ((max-width most-negative-fixnum) @@ -605,6 +609,11 @@ :font-list :margin-height :highlight-thickness :shadow-thickness) (let ((font-height (nth-value 1 (font-list-max-width-and-height font-list)))) (+ (* 2 (+ margin highlight shadow)) (* font-height chars)))))) + +(defun text-gadget-margin-height (sheet) + (multiple-value-bind (margin highlight shadow) + (tk::get-values (sheet-direct-mirror sheet) :margin-height :highlight-thickness :shadow-thickness) + (+ (* 2 (+ margin highlight shadow))))) #+ignore diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 35eb162d..a33d6d70 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.32 93/03/31 10:40:23 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.33 93/04/02 13:37:30 cer Exp $ (in-package :xm-silica) @@ -71,7 +71,7 @@ (append (let ((x (find-shell-of-calling-frame sheet))) (and x `(:transient-for ,x))) - ;;'(:keyboard-focus-policy :pointer) + '(:keyboard-focus-policy :pointer) (and (typep (pane-frame sheet) 'clim-internals::menu-frame) '(:override-redirect t)))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index f1d621e9..19a4f23b 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.67 93/03/31 10:40:30 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.68 93/04/02 13:37:36 cer Exp $ (in-package :tk-silica) @@ -1538,59 +1538,20 @@ (min-char (xt::font-range font)) (ascent (xt::font-ascent font)) (descent (xt::font-descent font))) - (multiple-value-bind - (pixmap columns - width - leftover-width - rows height - leftover-height) - (find-rotated-text-pixmap - port font rotation) - (flet ((compute-next-x-and-y (char-width x y) - (let () - (case rotation - (0 (values (+ x char-width) y)) - (3 (values x (- y char-width))) - (2 (values (- x char-width) y)) - (1 (values x (+ y char-width)))))) - (compute-clip-x-and-clip-y (char char-width x y) - ;;-- This has to get to the right character in the pixmap - (multiple-value-bind - (row column) - (truncate (- char min-char) columns) - ;; Now we have to take into account the rotation - (let ((columns columns) - (rows rows)) - #+debug - (format t "Was Row ~D of ~D, Column ~D of ~D~%" - row rows column columns) - (dotimes (i rotation) - (psetf column (- (1- rows) row) row column) - (rotatef rows columns))) - #+debug - (format t "Now Row ~D of ~D, Column ~D of ~D~%" - row rows column columns) - (let ((px (* column (if (oddp rotation) height width))) - (py (* row (if (oddp rotation) width height))) - (w (- width char-width))) - (ecase rotation - (0) - (3 (incf py leftover-width) - (incf py w)) - (2 (incf px leftover-width) - (incf px w) - (incf py leftover-height)) - (1 (incf px leftover-height))) - #+debug - (format t "x ~D y ~D px ~D py ~D~%" x y px py) - (values (- x px) (- y py)))))) - (let ((ox x) - (oy y)) - (declare (ignore oy) - (ignore ox)) - - (setf (tk::gcontext-clip-mask gcontext) pixmap) - (setf (ink-gcontext-last-medium-clip-mask gcontext) nil) + (multiple-value-bind + (pixmap columns + width + leftover-width + rows height + leftover-height) + (find-rotated-text-pixmap + port font rotation) + (flet () + + + #+ignore (setf (tk::gcontext-clip-mask gcontext) pixmap) + #+ignore (setf (ink-gcontext-last-medium-clip-mask gcontext) nil) + (unless start (setq start 0)) (unless end (setq end (length string))) @@ -1601,43 +1562,174 @@ drawable 0 0) #+debug (progn + (setf (tk::gcontext-clip-mask gcontext) pixmap) (setf (tk::gcontext-clip-x-origin gcontext) 0 (tk::gcontext-clip-y-origin gcontext) 70) (tk::draw-rectangle drawable gcontext 0 70 256 256 t)) - - #-debug - (dotimes (i (- end start)) - (let* ((char (char-int (aref string (+ start i)))) - (char-width (xt::char-width font char)) - (cx x) - (cy y)) + + ;;-- This should be drawing onto an appropriately size bitmap + ;;-- that should be cached + ;;-- Width/height is the width of string + ;;-- Height/width is the height of the font + + (multiple-value-bind (string-pixmap pixmap-width pixmap-height) + (find-or-cache-string-pixmap port + string start end font + ascent descent height rotation pixmap + min-char columns rows width + leftover-width leftover-height) + ;; Now its time to + (multiple-value-bind (dst-x dst-y) + (ecase rotation + (0 (values x (- y ascent))) + (1 (values (- x descent) y)) + (2 (values (- x pixmap-width) (- y descent))) + (3 (values (- x ascent) (- y pixmap-height)))) + + (setf (tk::gcontext-clip-mask gcontext) string-pixmap) + (setf (ink-gcontext-last-medium-clip-mask gcontext) nil) + (setf (tk::gcontext-clip-x-origin gcontext) dst-x + (tk::gcontext-clip-y-origin gcontext) dst-y) + (tk::draw-rectangle drawable gcontext + dst-x dst-y pixmap-width + pixmap-height t)))))))) + +#+ignore +(defun clear-rotation-caches (&optional (port (find-port))) + (setf (tk-silica::port-rotated-font-cache port) nil + (xm-silica::port-rotated-string-cache port) nil)) +#+ignore +(clear-rotation-caches) + +(defun find-or-cache-string-pixmap (port string start end font ascent + descent height rotation pixmap + min-char columns rows width + leftover-width leftover-height) + (psetq string (subseq string start end) + start 0 + end (- end start)) + (let ((strings-for-font (assoc (cons rotation font) + (port-rotated-string-cache port) + :test #'equal))) + (let ((res (assoc string (cdr strings-for-font) :test #'string=))) + (when res (return-from find-or-cache-string-pixmap + (values-list (cdr res))))) + (flet ((compute-string-dimensions () + (values (do ((r 0) + (i start (1+ i))) + ((= i end) r) + (incf r + (xt::char-width font (char-int (aref string i))))) + (+ ascent descent))) + (compute-clip-x-and-clip-y (char char-width) + ;;-- This has to get to the right character in the pixmap + (multiple-value-bind + (row column) + (truncate (- char min-char) columns) + ;; Now we have to take into account the rotation + (let ((columns columns) + (rows rows)) + #+debug + (format t "Was Row ~D of ~D, Column ~D of ~D~%" + row rows column columns) + (dotimes (i rotation) + (psetf column (- (1- rows) row) row column) + (rotatef rows columns))) + #+debug + (format t "Now Row ~D of ~D, Column ~D of ~D~%" + row rows column columns) + (let ((px (* column (if (oddp rotation) height width))) + (py (* row (if (oddp rotation) width height))) + (w (- width char-width))) + (ecase rotation + (0) + (3 (incf py leftover-width) + (incf py w)) + (2 (incf px leftover-width) + (incf px w) + (incf py leftover-height)) + (1 (incf px leftover-height))) + #+debug + (format t "x ~D y ~D px ~D py ~D~%" x y px py) + (values px py)))) + (compute-next-x-and-y (char-width x y) + (let () + (case rotation + ;; Normal + (0 (values (+ x char-width) y)) + ;; -ve y coordinates (up) + (3 (values x (- y char-width))) + ;; -ve x (back) + (2 (values (- x char-width) y)) + ;; +ve y (down) + (1 (values x (+ y char-width))))))) + (multiple-value-bind (string-width string-height) + (compute-string-dimensions) + (multiple-value-bind (pixmap-width pixmap-height) + (ecase rotation + ((0 2) (values string-width string-height)) + ((1 3) (values string-height string-width))) + (let ((string-pixmap (make-instance 'tk::pixmap + :depth 1 + :drawable pixmap + :width pixmap-width + :height + pixmap-height))) + #+ignore + (tk::draw-rectangle string-pixmap clear-gc + 0 0 + pixmap-width pixmap-height + t) + (multiple-value-bind (x y) + (ecase rotation + (0 (values 0 ascent)) + (1 (values descent 0)) + (2 (values pixmap-width descent)) + (3 (values ascent pixmap-height))) + (let ((copy-gc (port-copy-gc-depth-1 port) + #+ignore (make-instance 'tk::gcontext + :drawable pixmap))) + (dotimes (i (- end start)) + (let* ((char (char-int (aref string (+ start i)))) + (char-width (xt::char-width font char)) + (cx x) + (cy y)) - (ecase rotation - (0 (decf cy ascent)) - (3 (decf cx ascent) - (decf cy char-width)) - (2 (decf cy descent) - (decf cx char-width)) - (1 (decf cx descent))) + (ecase rotation + (0 (decf cy ascent)) + (3 (decf cx ascent) + (decf cy char-width)) + (2 (decf cy descent) + (decf cx char-width)) + (1 (decf cx descent))) - (multiple-value-bind - (clip-x clip-y) - (compute-clip-x-and-clip-y char char-width cx cy) - #+debug - (format t "CLip-x, clip-y ~D,~D~%" clip-x clip-y) - (setf (tk::gcontext-clip-x-origin gcontext) clip-x - (tk::gcontext-clip-y-origin gcontext) clip-y - )) - ;;-- We have lost the clipping region at this point! - ;;--- We should draw in the background color also - (tk::draw-rectangle drawable gcontext - cx cy - (if (oddp rotation) height char-width) - (if (oddp rotation) char-width height) - t) - ;; - (multiple-value-setq - (x y) (compute-next-x-and-y char-width x y)))))))))) + (multiple-value-bind + (clip-x clip-y) + (compute-clip-x-and-clip-y char char-width) + #+debug + (format excl:*initial-terminal-io* "CLip-x, clip-y ~D,~D~%" + clip-x clip-y) + #+ignore + (setf (tk::gcontext-clip-x-origin gcontext) clip-x + (tk::gcontext-clip-y-origin gcontext) clip-y + ) + ;;-- We have lost the clipping region at this point! + ;;--- We should draw in the background color also + (tk::copy-area pixmap + copy-gc + clip-x clip-y + (if (oddp rotation) height char-width) + (if (oddp rotation) char-width height) + string-pixmap cx cy )) + ;; + (multiple-value-setq + (x y) (compute-next-x-and-y char-width x y)))))) + (unless strings-for-font + (push (setq strings-for-font (list (cons rotation font))) + (port-rotated-string-cache port))) + (push (list string string-pixmap pixmap-width pixmap-height) + (cdr strings-for-font)) + (values string-pixmap pixmap-width pixmap-height))))))) (defun find-rotated-text-pixmap (port font rotation) (let ((x (assoc (list font rotation) (port-rotated-font-cache port) @@ -1668,6 +1760,7 @@ :depth 1 :width n :height n)) + ;;--- Perhaps we should reuse this gc instead (gc (make-instance 'ink-gcontext :drawable pixmap :font font @@ -1692,6 +1785,7 @@ string) (incf col)) (rotate-pixmap pixmap rotation) + (xt::free-gcontext gc) (values-list (cdr (car (push (list* (list font rotation) @@ -1708,16 +1802,20 @@ ;; converted to clim, 19mar92 by nlc. ;; the bit array must be square and a power of two bits on a side. (let* ((array-size (xt::pixmap-width source-pixmap)) + ;;-- Perhaps we should be clever and reuse these if the next + ;;-- time through the map is the same (mask-pixmap (make-instance 'tk::pixmap - :drawable source-pixmap - :width array-size - :height array-size - :depth 1)) + :drawable source-pixmap + :width array-size + :height array-size + :depth 1)) (temp-pixmap (make-instance 'tk::pixmap - :drawable source-pixmap - :width array-size - :height array-size - :depth 1)) + :drawable source-pixmap + :width array-size + :height array-size + :depth 1)) + ;;-- Perhaps we should reuse this bitmap instead of + ;;-- destroying it (gc (make-instance 'ink-gcontext :drawable source-pixmap))) (dotimes (i n) (macrolet ((copy-all-to (from xoffset yoffset to alu) @@ -1753,7 +1851,10 @@ mask-pixmap boole-and) ;13 (copy-all-to mask-pixmap quad 0 mask-pixmap boole-ior) ; 14 (copy-all-to mask-pixmap 0 quad mask-pixmap boole-ior) ; 15 - ))))) + ))) + (xt::destroy-pixmap mask-pixmap) + (xt::destroy-pixmap temp-pixmap) + (xt::free-gcontext gc))) (defun stream-bitblt-support (gc from from-left from-top diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 7b7858f9..2da8f4bc 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.74 93/03/31 10:40:33 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.75 93/04/02 13:37:41 cer Exp $ (in-package :xm-silica) @@ -37,6 +37,7 @@ (event-lock :initform (clim-sys:make-lock "port event lock") :reader port-event-lock) (rotated-font-cache :initform nil :accessor port-rotated-font-cache) + (rotated-string-cache :initform nil :accessor port-rotated-string-cache) (depth :accessor port-depth) (visual-class :accessor port-visual-class) (cursor-font :initform nil) -- GitLab