Forked from
mcclim / clim-tos
453 commits behind the upstream repository.
-
cer authored
Makefile Link stub-xt.o into clim-motif/olit.o demo/navfun.lisp Deleted junk from flight planner tk-silica/xm-frames.lisp Fixed minor bug tk-silica/xt-graphics.lisp tk-silica/xt-pixmaps.lisp Added missing arg to xfreepixmap
cer authoredMakefile Link stub-xt.o into clim-motif/olit.o demo/navfun.lisp Deleted junk from flight planner tk-silica/xm-frames.lisp Fixed minor bug tk-silica/xt-graphics.lisp tk-silica/xt-pixmaps.lisp Added missing arg to xfreepixmap
xt-pixmaps.lisp 6.16 KiB
;; -*- mode: common-lisp; package: xm-silica -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-pixmaps.lisp,v 1.14 93/02/08 15:58:17 cer Exp $
(in-package :xm-silica)
(defmethod port-allocate-pixmap ((port xt-port) medium width height)
(declare (ignore medium))
(fix-coordinates width height)
(let ((root (tk::display-root-window (port-display port))))
(make-instance 'tk::pixmap
:drawable root
:width width
:height height
:depth (tk::drawable-depth root))))
(defmethod port-deallocate-pixmap ((port xt-port) (pixmap tk::pixmap))
(x11:xfreepixmap (port-display port) pixmap))
(defmethod pixmap-width ((pixmap tk::pixmap))
(tk::pixmap-width pixmap))
(defmethod pixmap-height ((pixmap tk::pixmap))
(tk::pixmap-height pixmap))
(defmethod pixmap-depth ((pixmap tk::pixmap))
(tk::pixmap-depth pixmap))
(defclass xt-pixmap-medium (xt-medium basic-pixmap-medium) ())
(defmethod make-pixmap-medium ((port xt-port) sheet &key width height)
(let* ((pixmap (port-allocate-pixmap port sheet width height))
(medium (make-instance 'xt-pixmap-medium
:port port
:sheet sheet
:pixmap pixmap)))
(setf (slot-value medium 'drawable) pixmap)
medium))
(defmethod medium-copy-area
((from-medium xt-medium) from-x from-y width height
(to-medium xt-medium) to-x to-y)
(let ((from-transform (sheet-native-transformation (medium-sheet from-medium)))
(to-transform (sheet-native-transformation (medium-sheet to-medium))))
(convert-to-device-coordinates from-transform from-x from-y)
(convert-to-device-coordinates to-transform to-x to-y)
(convert-to-device-distances from-transform width height)
(let* ((from-drawable (medium-drawable from-medium))
(to-drawable (medium-drawable to-medium))
(port (port from-medium))
(copy-gc (port-copy-gc port)))
(when (and from-drawable to-drawable)
(when (port-safe-backing-store port)
;; Don't bother with no-expose events.
(return-from medium-copy-area
(tk::copy-area from-drawable copy-gc from-x from-y
width height
to-drawable to-x to-y)))
(with-port-event-lock (port)
(let ((seq-no 0))
(clim-sys:without-scheduling
(setq seq-no (x11:xnextrequest (port-display port)))
(tk::copy-area from-drawable copy-gc from-x from-y
width height to-drawable to-x to-y))
(let ((event
(tk::get-event-matching-sequence-and-types
to-drawable seq-no
'(:graphics-expose :no-expose))))
(case (tk::event-type event)
(:no-expose
nil)
(:graphics-expose
(loop
(let* ((minx (x11::xexposeevent-x event))
(miny (x11::xexposeevent-y event))
(width (x11::xexposeevent-width event))
(height (x11::xexposeevent-height event))
(maxx (+ minx width))
(maxy (+ miny height)))
(let ((sheet (medium-sheet to-medium)))
(queue-repaint
sheet
(allocate-event 'window-repaint-event
:native-region (make-bounding-rectangle minx miny maxx maxy)
:region (untransform-region
(sheet-native-transformation sheet)
(make-bounding-rectangle minx miny maxx maxy))
:sheet sheet))))
(setq event (tk::get-event-matching-sequence-and-types
to-drawable seq-no '(:graphics-expose)
:block nil))
(unless event
(return))))))))))))
(defmethod medium-copy-area
((pixmap tk::pixmap) from-x from-y width height
(to-medium xt-medium) to-x to-y)
(let ((transform (sheet-native-transformation (medium-sheet to-medium))))
(convert-to-device-coordinates transform to-x to-y)
(let* ((window (medium-drawable to-medium))
(copy-gc (port-copy-gc (port to-medium))))
(tk::copy-area
pixmap copy-gc from-x from-y width height
window to-x to-y))))
(defmethod medium-copy-area
((from-medium xt-medium) from-x from-y width height
(pixmap tk::pixmap) to-x to-y)
;;; What about the graphics exposure event problem
(let ((transform (sheet-native-transformation (medium-sheet from-medium))))
(convert-to-device-coordinates transform from-x from-y)
(convert-to-device-distances transform width height)
(let* ((window (medium-drawable from-medium))
(copy-gc (port-copy-gc (port from-medium))))
(tk::copy-area
window copy-gc from-x from-y width height
pixmap to-x to-y))))
;;; I dont understand the need for these methods
;;; Also what is the xt-pixmap class below.
#+ignore
(defmethod medium-copy-area
((from-medium xt-medium) from-x from-y width height
(pixmap tk::pixmap) to-x to-y)
(let ((transform (sheet-native-transformation (medium-sheet from-medium))))
(convert-to-device-coordinates transform from-x from-y)
(convert-to-device-distances transform width height)
(let ((window (medium-drawable from-medium))
(copy-gc (make-instance 'tk::gcontext :drawable window)))
(tk::copy-area
window copy-gc from-x from-y width height
pixmap to-x to-y))))
#+ignore
(defmethod medium-copy-area
((pixmap tk::pixmap) from-x from-y width height
(to-medium xt-medium) to-x to-y)
(let ((transform (sheet-native-transformation (medium-sheet to-medium))))
(convert-to-device-coordinates transform to-x to-y)
(let ((window (medium-drawable to-medium))
(copy-gc (make-instance 'tk::gcontext :drawable window)))
(tk::copy-area
pixmap copy-gc from-x from-y width height
window to-x to-y))))