CLIM mail archive
[Prev][Next][Index][Thread]
Re: Rotated Text?
Date: Mon, 16 Mar 1992 11:01-0500
From: Scott McKay <SWM@sapsucker.scrc.symbolics.com>
Subject: Re: Rotated Text?
To: jmorrill@BBN.COM, rjb1%vega@gte.com
cc: clim@BBN.COM
Date: Fri, 13 Mar 1992 17:36 EST
From: Jeff Morrill <jmorrill@BBN.COM>
Date: Fri, 13 Mar 1992 16:03-0500
From: Richard J Brandau <rjb1%vega@gte.com>
Subject: Rotated Text?
To: clim@BBN.COM
Cc: Rjb1%vega@gte.com
OK, I give up: How does one get rotated text in CLIM 1.0?
As far as I know, that's not currently supported.
It could be done rather easily if there existed something like bitblt
on the Symbolics, which rotates arbitrary bit arrays. It might not
be the fastest thing in the world, but usually speed is not critical
when you are drawing things sideways. Most of us would be happy with
rotation in increments of 90 degrees, which is not real hard.
I have already asked for something like bitblt. I think
many CLIM users out there could use it. Perhaps
this would be a good time to ask the CLIM implementors
if this feature is in the works.
It's not in the works. Perhaps this would be a good time to ask some
good CLIM hacker out there to cobble something up? I would be glad to
privately supply code as a starting point for handling 90 degree
rotations.
-----------------------
Folks,
Here is some code that does exactly what I described. We have had
to spend a few days pulling the pieces together and cleaning it
all up.
All of us clim hackers think that this functionality would be an excellent
candidate for inclusion in CLIM 2.0. It requires access to a number
of clim internal protocols, and it will be difficult for us
to update and maintain as new clim releases appear.
Send suggestions, bug fixes, and extensions to me
(unless the clim implementors want the job).
Enjoy!
jeff morrill
jmorrill@bbn.com
-----------------------
;;; -*- Syntax: Common-lisp; Mode: LISP; Package: clim; -*-
(in-package :clim)
#|
---------------------------------------------
Written by: ncramer@bbn.com, jmorrill@bbn.com, mthome@bbn.com
Bolt, Beranek, and Newman
Written for: CLIM 1.0 (as an extension)
Version: 0.0 (23 March, 1992)
This code has been placed in the public domain by the authors.
We encourage those fixing or extending this code to send a
copy to the authors for inclusion in a future version.
---------------------------------------------
ALLOCATE-PIXMAP width height &key (clear-p t)
FREE-PIXMAP pixmap
WITH-PIXMAP symbol width height &key (clear-p t)
Allocates and frees a pixmap stream. This type of stream supports all graphics
operations but is never displayed. The purpose of a pixmap is typically to
perform offscreen drawing operations and then to use STREAM-BITBLT* to
copy it (or a portion of it) onto a displayed stream. It may also be useful
to copy from a displayed stream to a pixmap stream.
STREAM-BITBLT stream point-1 from-stream from-x from-y width height &key
STREAM-BITBLT* stream x y from-stream from-x from-y width height &key
Copies a rectangular portion of from-stream onto
a rectangular portion of to-stream.
DRAW-STRING-IMAGE stream string point-1 &key angle
DRAW-STRING-IMAGE* stream string x y &key angle
Draws a rotated character string. The current implementation only supports
angles in increments of pi/2. Positive angle = counterclockwise rotation.
|#
(defclass basic-pixmap ()
())
(defmethod pixmap-clear ((pixmap basic-pixmap))
(window-clear pixmap)
;; For some reason doing a simple WINDOW-CLEAR doesn't seem to work by itself...
(multiple-value-bind (LEFT TOP RIGHT BOTTOM)
(rectangle-edges* (window-viewport pixmap))
(multiple-value-bind (xoff yoff)
(window-margins pixmap)
(with-output-recording-options (pixmap :record-p nil :draw-p t)
(draw-rectangle* pixmap left top (- right xoff) (- bottom yoff)
:ink +background+
:filled t)))))
(defmethod pixmap-set-inside-size ((PIXMAP basic-pixmap) NEW-WIDTH NEW-HEIGHT)
;; Avoid unnecessary work, since this is done frequently.
(multiple-value-bind (LEFT TOP RIGHT BOTTOM) (window-inside-edges PIXMAP)
(unless (and (= (- RIGHT LEFT) NEW-WIDTH) (= (- BOTTOM TOP) NEW-HEIGHT))
(window-set-inside-edges PIXMAP LEFT TOP (+ LEFT NEW-WIDTH) (+ TOP NEW-HEIGHT)))))
;;;********************************************************************************
;;; CLX specific classes and methods.
;;;**********************************************************************NLC02DEC91
#+(and :xlib (not :genera))
(progn
(defclass clx-pixmap (clx-window basic-pixmap)
())
(defmethod initialize-instance :after ((SELF clx-pixmap) &key &allow-other-keys)
;; Turn on backing store, so the unexposed window remembers
;; what gets drawn to it.
(setf (xlib:window-backing-store (slot-value SELF 'window)) :always))
;;; Lie about these things, so the that we can draw to un-exposed windows.
(defmethod window-drawing-possible ((SELF clx-pixmap)) t)
(defmethod window-visibility ((SELF clx-pixmap)) t)
;;; The path seems to change (from platform to platform, release to release,
;;; sub-release to sub-release, phase o' the moon, etc...) so this may need
;;; massaging.
(defvar *CLX-PIXMAP-ROOT* nil)
(defun get-clx-pixmap-root ()
(or *CLX-PIXMAP-ROOT*
(setq *CLX-PIXMAP-ROOT*
(apply #'open-root-window
#+lucid `(:clx :host ,(lcl:environment-variable "DISPLAY"))
#-lucid `(:clx)))))
(defmethod stream-bitblt-support ((FROM-STREAM clx-window) FROM-LEFT FROM-TOP
(TO-STREAM clx-window) TO-LEFT TO-TOP
WIDTH HEIGHT &key FUNCTION)
;; NOTE: This being rather primitive, does not concern itself with Margins, etc.
;; If it does, then it gets confused when inside a presentation (which also
;; worries about such things).
(with-slots (COPY-GC) TO-stream
;; PROBABLY WANT TO CACHE COPIES OF THE GCONTEXTS
(xlib:with-gcontext (COPY-GC :function (or FUNCTION boole-1))
(xlib:copy-area (slot-value FROM-STREAM 'window)
COPY-GC FROM-LEFT FROM-TOP
WIDTH HEIGHT
(slot-value TO-STREAM 'window)
TO-LEFT TO-TOP))
))
(defmethod stream-bitblt-internal ((TO-STREAM clx-window) X-OFFSET Y-OFFSET
X Y
(FROM-STREAM clx-window) FROM-X FROM-Y
WIDTH HEIGHT INK FORCE-FROM-OUTPUT?)
(stream-bitblt-internal-helper TO-STREAM X-OFFSET Y-OFFSET X Y
FROM-STREAM FROM-X FROM-Y
WIDTH HEIGHT INK FORCE-FROM-OUTPUT?))
(defmethod draw-string-image-internal ((stream clx-window) x-offset y-offset
string x y ANGLE text-style)
(draw-string-image-internal-helper stream x-offset y-offset string x y ANGLE text-style))
(defun make-clx-pixmap (&key (RIGHT 100) (BOTTOM 100) (LEFT 0) (TOP 0))
(let* ((PIXMAP-ROOT (get-clx-pixmap-root))
(PIXMAP (make-instance 'clx-pixmap
:parent PIXMAP-ROOT
:left LEFT
:top TOP
:right RIGHT
:bottom BOTTOM
:scroll-bars nil
:borders nil
)))
PIXMAP))
) ; end of progn for (and :xlib (not :genera))
;;;********************************************************************************
;;; Genera specific classes and methods.
;;;**********************************************************************NLC08NOV91
#+genera
(progn
(scl:defflavor genera-pixmap-window ()
(tv:dont-select-with-mouse-mixin
tv:window)
(:default-init-plist
:deexposed-typeout-action :permit
:borders nil
:save-bits t
:blinker-p nil
:label nil))
;;; Make sure that it can't be exposed/selected/etc.
(scl:defwhopper (:expose genera-pixmap-window) (&rest IGNORE))
(scl:defwhopper (:deexpose genera-pixmap-window) (&rest IGNORE))
(scl:defwhopper (:selected genera-pixmap-window) (&rest IGNORE))
;;;
(scl:defflavor b&w-genera-pixmap-window () (genera-pixmap-window))
(defun make-b&w-genera-pixmap-window ()
(tv:make-window 'b&w-genera-pixmap-window
:borders nil))
(defclass genera-pixmap (sheet-window-stream basic-pixmap)
())
;;; For now (maybe forever) INK/ALU is ignored; i.e. this just draws it in.
;;; I'm assuming that's not too awful. After all that's what COPY-AREA-INTERNAL
;;; does. In any case, it's the only way I can get it to work.
(defmethod stream-bitblt-support ((FROM-STREAM sheet-window-stream) FROM-X FROM-Y
(TO-STREAM sheet-window-stream) X Y
WIDTH HEIGHT &key FUNCTION)
(let ((ALU (or FUNCTION boole-1)))
(scl::send (slot-value TO-STREAM 'WINDOW) :bitblt-from-sheet-to-sheet
ALU WIDTH HEIGHT
(slot-value FROM-STREAM 'WINDOW) FROM-X FROM-Y
X Y)))
(defmethod stream-bitblt-support :around
(FROM-STREAM FROM-X FROM-Y (TO-STREAM genera-pixmap)
TO-X TO-Y WIDTH HEIGHT &key FUNCTION)
(with-output-recording-options (TO-STREAM :record-p nil :draw-p t)
(call-next-method FROM-STREAM FROM-X FROM-Y
TO-STREAM TO-X TO-Y
WIDTH HEIGHT :function FUNCTION)))
(defmethod stream-bitblt-internal ((TO-STREAM sheet-implementation-mixin)
X-OFFSET Y-OFFSET
X Y
(FROM-STREAM sheet-implementation-mixin)
FROM-X FROM-Y
WIDTH HEIGHT INK FORCE-FROM-OUTPUT?)
(stream-bitblt-internal-helper TO-STREAM X-OFFSET Y-OFFSET X Y
FROM-STREAM FROM-X FROM-Y
WIDTH HEIGHT INK FORCE-FROM-OUTPUT?))
(defmethod draw-string-image-internal ((stream sheet-implementation-mixin) x-offset y-offset
string x y ANGLE text-style)
(draw-string-image-internal-helper stream x-offset y-offset string x y ANGLE text-style))
(defun make-genera-pixmap (&key (WIDTH 100) (HEIGHT 100) (screen tv:main-screen))
;; LIFTED FROM create-sheet-root-window
(let ((PIXMAP (make-instance
'genera-pixmap
:window (make-b&w-genera-pixmap-window)
:display-device-type
(let (#+IMach (device (scl:send screen :display-device-type)))
(cond
#+IMach
((and (find-package 'mtb)
(typep device
(intern "SMALL-SCREEN-GENERA-FONTS-MAC-DISPLAY-DEVICE"
'mtb)))
*small-sheet-device*)
(t *sheet-device*))))))
(pixmap-set-inside-size PIXMAP width height)
PIXMAP))
) ; end of progn for genera
;;;********************************************************************************
;;; PIXMAPS and BITBLT
;;;**********************************************************************NLC13NOV91
(defun make-pixmap (&key (width 100) (height 100))
#+Genera (make-genera-pixmap :width width :height height)
#+(and :xlib (not :genera)) (make-clx-pixmap :right width :bottom height))
(defvar *FREE-PIXMAPS-LIST* nil
"Simple Resource for recyclable PIXMAPS.")
(defun free-pixmap (PIXMAP)
(pushnew PIXMAP *FREE-PIXMAPS-LIST*)
nil)
(defun allocate-pixmap (width height &optional (clear-p t))
(let ((pm (pop *FREE-PIXMAPS-LIST*)))
(cond (pm
(pixmap-set-inside-size pm width height)
(if clear-p (pixmap-clear pm))
pm)
(t (make-pixmap :width width :height height)))))
(defmacro with-pixmap ((symbol WIDTH HEIGHT &key (CLEAR-P t)) &body BODY)
`(let ((,symbol (allocate-pixmap ,WIDTH ,HEIGHT ,CLEAR-P)))
(unwind-protect (progn ,@BODY)
(free-pixmap ,symbol))))
(defun stream-bitblt-internal-helper (TO-STREAM X-OFFSET Y-OFFSET X Y
FROM-STREAM FROM-X FROM-Y
WIDTH HEIGHT INK FORCE-FROM-OUTPUT?)
(declare (ignore INK))
(when (window-drawing-possible TO-STREAM)
(setq X (round x) Y (round y))
(translate-positions x-offset y-offset X Y)
(stream-bitblt-support FROM-STREAM FROM-X FROM-Y TO-STREAM X Y WIDTH HEIGHT)
(and FORCE-FROM-OUTPUT? (force-output FROM-STREAM))))
;;; NOTE: On CLX-based windows, the result of BITBLT-ing may not be displayed until
;;; a force-output is done on the FROM-STREAM (yes, that's what I said, the FROM-stream).
;;; However, force-output can be a very time consuming operation. Therefore, it
;;; only happens automatically (at most) in the call to STREAM-BITBLT
;;; itself. Lower level calls are responsible for doing it themselves.
(define-graphics-operation stream-bitblt (TO-X TO-Y FROM-STREAM FROM-X FROM-Y
WIDTH HEIGHT &key (FORCE-FROM-OUTPUT? t))
:arguments ((point TO-X TO-Y))
:drawing-options (:ink)
:method-body
(with-transformed-arguments
(stream-bitblt-internal STREAM 0 0
TO-X TO-Y
FROM-STREAM FROM-X FROM-Y
WIDTH HEIGHT (medium-ink STREAM)
FORCE-FROM-OUTPUT?)))
(define-graphics-internal stream-bitblt-internal
(TO-X TO-Y FROM-STREAM FROM-X FROM-Y WIDTH HEIGHT INK FORCE-FROM-OUTPUT?)
:points-to-convert (TO-X TO-Y)
:bounding-rectangle
(let (vx vt vr vb)
(setq vx TO-X
vr (the fixnum (+ TO-X WIDTH)))
(setq vt TO-Y
vb (the fixnum (+ TO-Y HEIGHT)))
(fix-rectangle vx vt vr vb)))
;;;********************************************************************************
;;; DRAW-STRING-WITH-ROTATION (STREAM STRING X Y &key :ANGLE :TEXT-STYLE)
;;; Support for string rotation by first drawing the string onto a Pixmap and
;;; then rotating it (through increments of 90dgs).
;;;**********************************************************************NLC20MAR92
;(defconstant *stor* boole-1) ; tv::alu-seta
;(defconstant *or* boole-ior)
;(defconstant *and* boole-and)
;(defconstant *xor* boole-xor)
;(defconstant *clr* boole-clr)
;(defconstant *set* boole-set)
;(defconstant *notand* boole-andc1)
;(defconstant *rotate-array-size* 256)
(defun pixmap-rotate-90-worker (SOURCE-PIXMAP ARRAY-SIZE)
;; Original code was in smalltalk from april 1981 Byte magazine.
;; This code is mostly from a symbolics lispm hack:
;; Created 11/24/81 by CMB
;; Modified, 1/9/82 by DLW
;; Converted to CLIM, 19MAR92 by NLC.
;; The bit array must be square and a power of two bits on a side.
(macrolet ((copy-all-to (from xoffset yoffset to alu)
`(stream-bitblt-support ,from 0 0
,to ,xoffset ,yoffset
(- array-size ,xoffset) (- array-size ,yoffset)
:function ,alu))
(copy-all-from (to xoffset yoffset from alu)
`(stream-bitblt-support ,from ,xoffset ,yoffset
,to 0 0
(- array-size ,xoffset) (- array-size ,yoffset)
:function ,alu)))
(with-pixmap (MASK-PIXMAP array-size array-size)
(with-output-recording-options (MASK-PIXMAP :record-p nil :draw-p t)
(with-pixmap (TEMP-PIXMAP array-size array-size)
(with-output-recording-options (TEMP-PIXMAP :record-p nil :draw-p t)
(copy-all-to MASK-PIXMAP 0 0 MASK-PIXMAP boole-clr)
(copy-all-from MASK-PIXMAP (/ array-size 2) (/ array-size 2)
MASK-PIXMAP boole-set)
(do ((quad (/ array-size 2) (/ quad 2)))
((< quad 1))
(copy-all-to MASK-PIXMAP 0 0 TEMP-PIXMAP boole-1); 1
(copy-all-to MASK-PIXMAP 0 quad TEMP-PIXMAP boole-ior); 2
(copy-all-to SOURCE-PIXMAP 0 0 TEMP-PIXMAP boole-and); 3
(copy-all-to TEMP-PIXMAP 0 0 SOURCE-PIXMAP boole-xor); 4
(copy-all-from TEMP-PIXMAP quad 0 SOURCE-PIXMAP boole-xor); 5
(copy-all-from SOURCE-PIXMAP quad 0 SOURCE-PIXMAP boole-ior); 6
(copy-all-to TEMP-PIXMAP quad 0 SOURCE-PIXMAP boole-xor); 7
(copy-all-to SOURCE-PIXMAP 0 0 TEMP-PIXMAP boole-1); 8
(copy-all-from TEMP-PIXMAP quad quad SOURCE-PIXMAP boole-xor); 9
(copy-all-to MASK-PIXMAP 0 0 TEMP-PIXMAP boole-and); 10
(copy-all-to TEMP-PIXMAP 0 0 SOURCE-PIXMAP boole-xor); 11
(copy-all-to TEMP-PIXMAP quad quad SOURCE-PIXMAP boole-xor); 12
(copy-all-from MASK-PIXMAP (floor quad 2) (floor quad 2)
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
)))
))))
(defun pixmap-rotate-90 (SOURCE-PIXMAP &key DEST-PIXMAP SOURCE-X SOURCE-Y
WIDTH HEIGHT DEST-X DEST-Y)
(or DEST-PIXMAP
(setq DEST-PIXMAP source-pixmap))
(unless SOURCE-X (setq SOURCE-X 0))
(unless SOURCE-Y (setq SOURCE-Y 0))
(unless dest-x (setq dest-x 0))
(unless dest-y (setq dest-y 0))
(with-output-recording-options (source-pixmap :record-p nil :draw-p t)
(with-output-recording-options (dest-pixmap :record-p nil :draw-p t)
(unless (and width height)
(multiple-value-bind (w h)
(multiple-value-bind (left top right bottom)
(rectangle-edges* (window-viewport source-pixmap))
(multiple-value-bind (xoff yoff)
(window-margins source-pixmap)
(values (- (- right xoff) left)
(- (- bottom yoff) top))))
(unless width (setq width w))
(unless height (setq height h))))
(let ((csz (expt 2 (ceiling (log
(max width height)
2)))))
(with-pixmap (HOLD-PIXMAP CSZ CSZ)
(with-output-recording-options (HOLD-PIXMAP :record-p nil :draw-p t)
(stream-bitblt-support source-pixmap SOURCE-X SOURCE-Y
HOLD-PIXMAP 0 0
WIDTH HEIGHT)
(pixmap-rotate-90-worker HOLD-PIXMAP csz)
(stream-bitblt-support HOLD-PIXMAP (- CSZ HEIGHT) 0
dest-pixmap DEST-X DEST-Y
HEIGHT WIDTH))))))
dest-pixmap)
(defun stream-bitblt-with-rotation (stream x y from-stream from-x from-y width height
&key (angle 0))
(if (zerop angle)
(stream-bitblt-support from-stream from-x from-y stream x y width height)
(let ((rotation-count (mod (round (- ANGLE) #.(/ PI 2.0)) 4))
(size (max WIDTH HEIGHT))
(x0 0)
(y0 0))
(with-pixmap (PM size size)
(with-output-recording-options (PM :record-p nil :draw-p t)
(stream-bitblt-support from-stream from-x from-y PM 0 0 width height)
(dotimes (i rotation-count)
(pixmap-rotate-90 PM :width size :height size))
(cond ((= rotation-count 1)
(decf x0 (- size width))
(decf x width)
(setq width (- size x0))
(setq height (- size y0))
)
((= rotation-count 2)
(incf y0 (- size height))
(decf x width)
(decf y height)
)
((= rotation-count 3)
(decf y width)
(rotatef width height)
))
(stream-bitblt-support PM x0 y0
STREAM x y
width height
)
(force-output pm) ; needed for CLX, but why????
)))))
(defun draw-string-with-rotation (STREAM STRING X Y &key (angle 0) TEXT-STYLE)
(if (zerop angle)
(with-output-recording-options (STREAM :record-p nil :draw-p t)
(draw-string-internal STREAM 0 0 STRING X Y 0 (length string)
:left :top TEXT-STYLE (medium-ink stream)))
(let ((width (stream-string-width stream string :text-style text-style))
(height (stream-line-height stream text-style)))
(with-pixmap (PM width height :clear-p nil)
(setf (medium-foreground PM) (medium-foreground STREAM)
(medium-background PM) (medium-background STREAM))
(pixmap-clear PM)
(draw-string* PM STRING 0 0
:align-x :left :align-y :top
:text-style TEXT-STYLE)
(stream-bitblt-with-rotation stream x y PM 0 0 width height :angle angle)))))
;;;********************************************************************************
;;; DRAW-STRING-IMAGE
;;;**********************************************************************NLC22MAR92
(defun draw-string-image-internal-helper (stream x-offset y-offset
string x y ANGLE text-style)
(when (window-drawing-possible stream)
(setq X (round x) Y (round y))
(translate-positions x-offset y-offset X Y)
(draw-string-with-rotation stream
string x y
:angle angle
:text-style TEXT-STYLE)))
(define-graphics-operation draw-string-image (string x y &key (ANGLE 0.0))
:arguments ((point x y))
:drawing-options :text
:method-body
(with-transformed-arguments
(draw-string-image-internal stream 0 0
string x y ANGLE
(stream-merged-text-style stream)
#+Ignore (medium-ink stream))))
(defun rot-90-string-locations (STREAM STRING X Y ANGLE TEXT-STYLE)
(declare (values IMAGE-LEFT IMAGE-TOP
IMAGE-WIDTH IMAGE-HEIGHT
REAL-WIDTH REAL-HEIGHT))
(let ((N-ROT-90 (mod (round (- ANGLE) #.(/ PI 2.0)) 4))
(STR-WID (stream-string-width stream string :text-style text-style))
(STR-HEI (stream-line-height stream text-style)))
(case N-ROT-90
(3
(values X (- Y STR-WID) STR-HEI STR-WID STR-WID STR-HEI))
(2
(values (- X STR-WID) (- Y STR-HEI) STR-WID STR-HEI STR-WID STR-HEI))
(1
(values (- X STR-HEI) Y STR-HEI STR-WID STR-WID STR-HEI))
(otherwise
(values X Y STR-WID STR-HEI STR-WID STR-HEI)))))
(define-graphics-internal draw-string-image-internal (STRING X Y ANGLE TEXT-STYLE)
:points-to-convert (x y)
;; Don't want temporary strings to make it into the history
:output-recording-hook (setq string (evacuate-temporary-string string))
:bounding-rectangle
(progn
(multiple-value-bind (LLL TTT WWW HHH)
(rot-90-string-locations stream string x y angle TEXT-STYLE)
(declare (fixnum WWW HHH))
(let ((vx LLL)
(vt TTT)
(vr (the fixnum (+ LLL WWW)))
(vb (the fixnum (+ TTT HHH))))
#+ig (fix-rectangle vx vt vr vb);; allegro gets an error with this
(values vx vt vr vb)
))))
Main Index |
Thread Index