diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp new file mode 100644 index 0000000000000000000000000000000000000000..45cbc3cc62d397d29ff9c6a11e3847b8b2dadc4a --- /dev/null +++ b/clim/pixmap-streams.lisp @@ -0,0 +1,98 @@ +;; -*- mode: common-lisp; package: clim-internals -*- +;; +;; -[]- +;; +;; 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$ + +(in-package :clim-internals) + +(defclass pixmap-stream (input-protocol-mixin + output-protocol-mixin + sheet-permanently-enabled-mixin + mirrored-sheet-mixin + permanent-medium-sheet-output-mixin + sheet-transformation-mixin + sheet) + ()) + +(defmethod realize-mirror ((port port) (stream pixmap-stream)) + nil) + +(defmethod silica::update-mirror-transformation ((port port) (sheet pixmap-stream)) + nil) + +(defmethod silica::update-mirror-region ((port port) (sheet pixmap-stream)) + nil) + +(defmethod initialize-instance :after ((stream pixmap-stream) &key + port + pixmap + width height) + (setf (sheet-direct-mirror stream) pixmap + (sheet-port stream) port + (sheet-transformation stream) +identity-transformation+ + (sheet-region stream) (make-bounding-rectangle 0 0 width + height))) + +;; Interface to this stuff + +(defmacro with-output-to-pixmap-stream ((stream sheet . options) &body body) + (clim-utils::default-output-stream stream with-output-to-pixmap-stream) + `(flet ((with-output-to-pixmap-body (,stream) ,@body)) + (declare (dynamic-extent #'with-output-to-pixmap-body)) + (invoke-with-output-to-pixmap ,sheet + #'with-output-to-pixmap-body + ,@options))) + +(defmethod invoke-with-output-to-pixmap (sheet continuation &key width height) + (let* ((pixmap (allocate-pixmap sheet width height)) + (stream (allocate-pixmap-stream sheet pixmap width height))) + (funcall continuation stream) + pixmap)) + + +(defmethod allocate-pixmap (sheet width height) + (port-allocate-pixmap (sheet-port sheet) sheet width height)) + +(defmethod allocate-pixmap-stream (sheet pixmap width height) + (make-instance 'pixmap-stream + :default-text-margin width + :pixmap pixmap + :width width + :height height + :port (sheet-port sheet))) + +(defun copy-from-pixmap (pixmap pixmap-x pixmap-y width height + stream window-x window-y) + (port-copy-from-pixmap + (sheet-port stream) + pixmap pixmap-x pixmap-y width height stream window-x window-y)) + +(defun copy-to-pixmap (stream + window-x window-y width height + &optional pixmap (pixmap-x 0) (pixmap-y 0)) + (unless pixmap + (setf pixmap (allocate-pixmap stream width height))) + (port-copy-to-pixmap (sheet-port stream) + stream + window-x window-y width height + pixmap pixmap-x pixmap-y) + pixmap) diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2477d1f3cb184535a052925ab08a1ba83c3605c3 --- /dev/null +++ b/tk-silica/xt-pixmaps.lisp @@ -0,0 +1,94 @@ +;; -*- 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$ + + +(in-package :xm-silica) + +(defmethod clim-internals::port-allocate-pixmap ((port xt-port) sheet width height) + (declare (ignore sheet)) + (assert (integerp width)) + (assert (integerp height)) + (make-instance 'tk::pixmap + :drawable (tk::display-root-window (port-display port)) + :width width + :height height + :depth 8)) + +(defmethod fetch-medium-drawable ((sheet clim-internals::pixmap-stream) pixmap) + pixmap) + +(defun test-wotps () + (with-output-to-pixmap-stream (s (find-graft) :width 200 :height 200) + (window-clear s) + (draw-rectangle* s 0 0 200 200 :ink +background-ink+) + (write-line "hello" s) + (draw-line* s 0 0 100 100 :ink +red+))) + +(defmethod clim-internals::port-copy-from-pixmap ((port xt-port) + pixmap pixmap-x pixmap-y + width height stream + window-x window-y) + (multiple-value-setq + (window-x window-y) + (devicize-point (sheet-native-transformation stream) window-x + window-y)) + ;; We are in a bad situation if the native-transformation is + ;; anything other than a scaling transformation + (with-sheet-medium (medium stream) + (let* ((drawable (medium-drawable medium)) + (copy-gc (make-instance 'tk::gcontext :drawable drawable))) + (tk::copy-area + pixmap + copy-gc pixmap-x pixmap-y width height drawable + window-x window-y)))) + +(defmethod clim-internals::port-copy-to-pixmap ((port xt-port) + stream + window-x window-y width height + pixmap pixmap-x + pixmap-y) + (multiple-value-setq + (window-x window-y) + (devicize-point (sheet-native-transformation stream) window-x window-y)) + ;; We are in a bad situation if the native-transformation is + ;; anything other than a scaling transformation + (with-sheet-medium (medium stream) + (let* ((drawable (medium-drawable medium)) + (copy-gc (make-instance 'tk::gcontext :drawable drawable))) + (tk::copy-area + drawable + copy-gc + window-x window-y width height pixmap + pixmap-x pixmap-y)))) + +(defmethod clim-internals::pixmap-height ((pixmap tk::pixmap)) + (tk::pixmap-height pixmap)) + +(defmethod clim-internals::pixmap-width ((pixmap tk::pixmap)) + (tk::pixmap-width pixmap)) + +(defmethod clim-internals::deallocate-pixmap ((pixmap tk::pixmap)) + (break "implement me")) + +