From f457a34a3bcff76025c68f6adf643177cf4f4670 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Thu, 2 Jan 1992 15:12:33 +0000 Subject: [PATCH] fixes --- Makefile | 12 ++ clim/accept-values.lisp | 123 ++++++++++---------- clim/clim-defs.lisp | 13 +++ clim/db-stream.lisp | 24 +++- clim/frames.lisp | 100 ++++++++++------ clim/graph-formatting.lisp | 15 +-- clim/input-protocol.lisp | 7 +- clim/menus.lisp | 22 +++- clim/output-protocol.lisp | 3 +- clim/output-recording-defs.lisp | 172 +++++++++++++++++++++++---- clim/stream-defprotocols.lisp | 23 +++- clim/surround-output.lisp | 25 ++-- clim/sysdcl.lisp | 2 + clim/table-formatting.lisp | 108 +++++++++-------- clim/text-output-recording.lisp | 32 +++--- misc/go.lisp | 8 +- notes/plan.todo | 126 ++------------------ silica/classes.lisp | 5 +- silica/clim.lisp | 5 +- silica/db-box.lisp | 8 +- silica/db-layout.lisp | 75 +++++++++--- silica/db-table.lisp | 19 +-- silica/defsys.lisp | 3 + silica/event.lisp | 5 +- silica/graphics.lisp | 46 +++++--- silica/medium.lisp | 126 ++++++++++++++++++-- silica/mirror.lisp | 6 +- silica/pkg.lisp | 5 +- silica/port.lisp | 6 +- silica/protocols.lisp | 1 + silica/sheet.lisp | 5 +- silica/std-sheet.lisp | 6 +- silica/sysdcl.lisp | 35 ------ silica/text-style.lisp | 17 ++- test/test-suite.lisp | 42 +++++-- test/test.lisp | 19 +++ tk-silica/image.lisp | 25 ++++ tk-silica/pkg.lisp | 2 + tk-silica/sysdcl.lisp | 10 +- tk-silica/xm-frames.lisp | 21 +++- tk-silica/xm-gadgets.lisp | 37 +++--- tk-silica/xm-graphics.lisp | 198 +++++++++++++++++++++++++------- tk-silica/xm-silica.lisp | 39 +++++-- tk/callbacks.lisp | 24 ++++ tk/convenience.lisp | 24 ++++ tk/defsys.lisp | 24 ++++ tk/event.lisp | 24 ++++ tk/examples.lisp | 24 ++++ tk/font.lisp | 24 ++++ tk/foreign-obj.lisp | 24 ++++ tk/gcontext.lisp | 48 ++++++-- tk/graphics.lisp | 71 ++++++++++++ tk/init.lisp | 24 ++++ tk/load-ol.lisp | 24 ++++ tk/load-xm.lisp | 24 ++++ tk/loadit.lisp | 24 ++++ tk/macros.lisp | 24 ++++ tk/make-classes.lisp | 24 ++++ tk/ol-examples.lisp | 24 ++++ tk/ol-init.lisp | 24 ++++ tk/pkg.lisp | 24 ++++ tk/resources.lisp | 33 +++++- tk/widget.lisp | 31 +++++ tk/xlib.lisp | 101 +++++++++++++++- tk/xm-init.lisp | 24 ++++ tk/xm-protocols.lisp | 24 ++++ tk/xm-widgets.lisp | 24 ++++ tk/xtk.lisp | 24 ++++ utils/condpat.lisp | 1 + utils/defun-utilities.lisp | 1 + utils/reader.lisp | 1 + utils/regions.lisp | 75 +++++++----- 72 files changed, 1870 insertions(+), 553 deletions(-) delete mode 100644 silica/sysdcl.lisp diff --git a/Makefile b/Makefile index 97bac99b..2f2bf087 100644 --- a/Makefile +++ b/Makefile @@ -16,3 +16,15 @@ FRC : swm-tape: tar cf $(DEVICE) `find misc $(SOMEDIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print` + +xm-composer: + cd tk ; $(MAKE) xm-composer + +xm-dcl: + cd tk ; $(MAKE) xm-dcl + +# For the day the make dist happens. + +echo_src_files: + @find . '(' -name '*.cl' -o -name '*.lisp' ')' -print + diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index e83529ed..76ac8593 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: accept-values.lisp,v 1.10 91/08/05 13:25:15 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.1 91/11/25 10:00:56 cer Exp Locker: cer $ (in-package :clim) @@ -190,6 +190,23 @@ Copyright (c) 1991, Franz Inc. All rights reserved (:top-level (accept-values-top-level)) (:command-definer t)) +(define-application-frame accept-values-own-window (accept-values) + () + (:pane + (with-slots (stream own-window) *application-frame* + (silica::scrolling () + (progn + (setq stream + (make-instance 'avv-stream + :stream + (setf own-window + (silica::realize-pane 'extended-stream-pane + :initial-cursor-visibility nil + )))) + own-window)))) + (:command-table accept-values) + (:command-definer nil)) + ;; So the continuation can run with the proper value of *APPLICATION-FRAME* (defvar *avv-calling-frame*) @@ -202,69 +219,46 @@ Copyright (c) 1991, Franz Inc. All rights reserved (let ((the-own-window nil) (right-margin 10) (bottom-margin 10)) - (unwind-protect - (progn - (when own-window - #+Silica - (error "Own-window AVV not supported yet.") - (setq the-own-window - (allocate-resource 'menu stream (window-root stream))) - ;;--- make the window big. We shouldn't have to do this. - (multiple-value-bind (width height) - (window-inside-size (slot-value the-own-window 'parent)) - (bounding-rectangle-set-size the-own-window width height)) - (setf (window-label the-own-window) label) - (when (listp own-window) - (setf right-margin - (process-spacing-arg the-own-window (getf own-window :right-margin 10) - 'accepting-values :right-margin)) - (setf bottom-margin - (process-spacing-arg the-own-window (getf own-window :bottom-margin 10) - 'accepting-values :bottom-margin)))) - - (clim-utils::using-resource (avv-stream avv-stream (or the-own-window stream)) - ;;--- This should resource the AVV application frame, too - (let ((frame - #+Silica - (make-application-frame (or frame-class 'accept-values) - :stream avv-stream - :continuation continuation - :exit-boxes exit-boxes - :own-window the-own-window - :x-position x-position - :y-position y-position - :right-margin right-margin - :bottom-margin bottom-margin - :initially-select-query-identifier - initially-select-query-identifier - :resynchronize-every-pass - resynchronize-every-pass - :check-overlapping check-overlapping) - #-Silica - (make-application-frame 'accept-values - :parent (slot-value avv-stream 'stream) - :frame-class frame-class - :stream avv-stream - :exit-boxes exit-boxes - :continuation continuation - :own-window the-own-window - :x-position x-position - :y-position y-position - :right-margin right-margin - :bottom-margin bottom-margin - :initially-select-query-identifier - initially-select-query-identifier - :resynchronize-every-pass - resynchronize-every-pass - :check-overlapping check-overlapping))) - (when (silica::frame-top-level-sheet frame) - (window-expose (frame-top-level-window frame))) - ;; Run the AVV and return its values - (let ((*avv-calling-frame* *application-frame*)) - (run-frame-top-level frame))))) - (when (and the-own-window (windowp the-own-window)) - ;; Deallocate menu resources deexposes them for us - (deallocate-resource 'menu the-own-window))))) + (if own-window + (let ((frame (make-application-frame (or frame-class 'accept-values-own-window) + :continuation continuation + :exit-boxes exit-boxes + :own-window the-own-window + :x-position x-position + :y-position y-position + :right-margin right-margin + :bottom-margin bottom-margin + :initially-select-query-identifier + initially-select-query-identifier + :resynchronize-every-pass + resynchronize-every-pass + :check-overlapping + check-overlapping))) + ;; What do we do about sizing????? + ;; What do we do about positioning???? + (let ((*avv-calling-frame* *application-frame*)) + (run-frame-top-level frame))) + (clim-utils::using-resource (avv-stream avv-stream (or the-own-window stream)) + ;;--- This should resource the AVV application frame, too + (let ((frame + (make-application-frame (or frame-class 'accept-values) + :stream avv-stream + :continuation continuation + :exit-boxes exit-boxes + :own-window the-own-window + :x-position x-position + :y-position y-position + :right-margin right-margin + :bottom-margin bottom-margin + :initially-select-query-identifier + initially-select-query-identifier + :resynchronize-every-pass + resynchronize-every-pass + :check-overlapping + check-overlapping))) + ;; Run the AVV and return its values + (let ((*avv-calling-frame* *application-frame*)) + (run-frame-top-level frame))))))) (defmethod accept-values-top-level ((frame accept-values) &rest args) (declare (ignore args)) @@ -327,6 +321,7 @@ Copyright (c) 1991, Franz Inc. All rights reserved (with-end-of-page-action (:allow stream) (with-new-output-record (stream 'avv-output-record avv-record) (run-continuation stream avv-record))))))) + #+ignore (replay avv stream) (unwind-protect (cond (own-window diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index 052fe5de..c6b0e0a8 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -397,3 +397,16 @@ :transformation (make-rotation-transformation ,angle ,@(if origin-p `(,origin) nil))) ,@body)) + +(defmacro with-local-coordinates ((&optional stream) &body body) + (default-output-stream stream with-local-coordinates) + (let (( x '#:x) ( y '#:y) + (tx '#:tx) (ty '#:ty)) + `(multiple-value-bind (,x ,y) + (stream-cursor-position* ,stream) + (multiple-value-bind (,tx ,ty) + (transform-point* (medium-transformation ,stream) 0 0) + (with-drawing-options + (,stream :transformation (make-translation-transformation + (- ,x ,tx) (- ,y ,ty))) + ,@body))))) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index cb2edb48..163f3d66 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -82,9 +82,22 @@ ) () (:default-initargs :medium t - :max-width +fill+ :min-width 0 :max-height +fill+ :min-height 0)) - - + ;;:max-width +fill+ :min-width 0 :max-height +fill+ :min-height 0 + )) + +(defmethod silica::default-space-requirements ((pane extended-stream-sheet) + &key + (width 0 widthp) + (min-width width) + (max-width + (if widthp width + +fill+)) + (height 0 heightp) + (min-height height) + (max-height + (if heightp height +fill+))) + + (values width min-width max-width height min-height max-height)) ;;; We should straighten this out so that this can be ;;; subclass of LEAF-PANE. Then it would get @@ -151,7 +164,10 @@ (apply #'call-next-method pane :width (max width history-width) :height (max height history-height) keys))) (defclass basic-clim-interactor (extended-stream-pane) - ((display-function :initarg :display-function + ((incremental-redisplay-p + :initarg :incremental-redisplay + :initform nil) + (display-function :initarg :display-function :initform nil :reader pane-display-function) (display-time :initarg :display-time diff --git a/clim/frames.lisp b/clim/frames.lisp index 0cfb6e9f..b58e812e 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -38,8 +38,8 @@ (panes :initarg :panes :accessor frame-panes) (top-level-sheet :accessor frame-top-level-sheet :initform nil) (shell :accessor frame-shell) - (state :initform :disabled :accessor frame-state - :type (member :disabled :enable :disabled :shrunk)) + (state :initform :disowned :accessor frame-state + :type (member :disowned :disabled :enabled :shrunk)) (command-table :initarg :command-table :initform (find-command-table 'user-command-table) :accessor frame-command-table) @@ -154,9 +154,21 @@ (ecase (frame-state frame) (:enabled) ((:disabled :disowned) - (setf (frame-state frame) :enabled) - (layout-frame frame) - (note-frame-enabled (frame-manager frame) frame)))) + (let ((old (frame-state frame))) + (setf (frame-state frame) :enabled) + ;; IF this is a new frame then if the user specified a width + ;; then we should be using that + ;; IF the frame already exists then we probably should be using + ;; the top level sheet size + (multiple-value-call + #'layout-frame + frame + (ecase old + (:disowned (values)) + (:disabled + (bounding-rectangle-size + (frame-top-level-sheet frame))))) + (note-frame-enabled (frame-manager frame) frame))))) (defmethod disable-frame ((frame application-frame)) (ecase (frame-state frame) @@ -166,15 +178,16 @@ (note-frame-disabled (frame-manager frame) frame)))) (defmethod layout-frame ((frame application-frame) &optional width height) - (unless (and width height) - (let ((sr (compose-space (frame-panes frame)))) - (setq width (silica::space-req-width sr) - height (silica::space-req-height sr)))) - (allocate-space (frame-panes frame) width height) - #+shouldwebedoingthiskindofthing? - (when (frame-top-level-sheet frame) - (silica::resize-sheet* (frame-top-level-sheet frame) - width height))) + (when (frame-panes frame) + (unless (and width height) + (let ((sr (compose-space (frame-panes frame)))) + (setq width (silica::space-req-width sr) + height (silica::space-req-height sr)))) + (allocate-space (frame-panes frame) width height) + ;; This is quite likely not going to work + (when (frame-top-level-sheet frame) + (silica::resize-sheet* (frame-top-level-sheet frame) + width height)))) (defun make-application-frame (class &rest options &key enable &allow-other-keys) (with-rem-keywords (options options '(:enable)) @@ -194,18 +207,22 @@ (call-next-method)))) (defmethod run-frame-top-level ((frame application-frame)) - (unless (eq (frame-state frame) :enabled) - (enable-frame frame)) - (let ((tl (frame-top-level frame))) - (if (atom tl) - (funcall tl frame) - (apply (car tl) frame (cdr tl))))) + (unwind-protect + (progn + (let ((tl (frame-top-level frame))) + (if (atom tl) + (funcall tl frame) + (apply (car tl) frame (cdr tl))))) + (disable-frame frame))) (defun command-enabled-p (command frame) t) (defmethod default-frame-top-level (frame &key command-parser command-unparser partial-command-parser (prompt "Command: ")) + + (unless (eq (frame-state frame) :enabled) + (enable-frame frame)) (let* ((*standard-output* (or (frame-standard-output frame) *standard-output*)) (*query-io* (or (frame-query-io frame) *query-io*)) (interactor (find-frame-pane-of-type frame 'interactor-pane)) @@ -224,18 +241,19 @@ #'command-line-read-remaining-arguments-for-partial-command #'menu-only-read-remaining-arguments-for-partial-command)))) (loop - (redisplay-frame-panes frame) - (when interactor - (fresh-line *standard-input*) - (if (stringp prompt) - (write-string prompt *standard-input*) - (funcall prompt *standard-input* frame))) - (let ((command (read-frame-command frame :stream *standard-input*))) + (clim-utils::with-simple-abort-restart ("Abort Command") + (redisplay-frame-panes frame) (when interactor - (terpri *standard-input*)) - ;; Need this check in case the user aborted out of a command menu - (when command - (execute-frame-command frame command)))))) + (fresh-line *standard-input*) + (if (stringp prompt) + (write-string prompt *standard-input*) + (funcall prompt *standard-input* frame))) + (let ((command (read-frame-command frame :stream *standard-input*))) + (when interactor + (terpri *standard-input*)) + ;; Need this check in case the user aborted out of a command menu + (when command + (execute-frame-command frame command))))))) (defmethod redisplay-frame-panes (frame &key force-p) (map-over-sheets #'(lambda (sheet) @@ -245,9 +263,23 @@ (frame-top-level-sheet frame))) (defun redisplay-frame-pane (frame pane &key force-p) - (declare (ignore frame force-p)) (when (pane-display-function pane) - (invoke-pane-redisplay-function frame pane))) + (let* ((ird (slot-value pane 'incremental-redisplay-p)) + (history + (and ird + (output-recording-stream-output-record pane))) + (record (and history + (> (output-record-count history) 0) + (output-record-element history 0)))) + (cond ((and ird (or force-p (null record))) + (when force-p + (window-clear pane)) + (updating-output (pane) + (invoke-pane-redisplay-function frame pane))) + (ird + (redisplay record pane)) + (t + (invoke-pane-redisplay-function frame pane)))))) (defun invoke-pane-redisplay-function (frame pane) (let ((fn (pane-display-function pane))) @@ -256,8 +288,10 @@ (apply (car fn) frame pane (cdr fn))))) (defun execute-frame-command (frame command) + (declare (ignore frame)) (apply (command-name command) (command-arguments command))) + (defun frame-find-innermost-applicable-presentation (frame input-context history-window px py) diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index bc5b61c5..fe0cd772 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,13 +1,13 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graph-formatting.lisp,v 1.7 91/08/05 14:29:31 cer Exp $ +;; $fiHeader: graph-formatting.cl,v 1.1 91/12/17 13:58:42 cer Exp Locker: cer $ (in-package :clim) "Copyright (c) 1989, 1990 International Lisp Associates. All rights reserved." "Copyright (c) 1991, Franz Inc. All rights reserved" -(defclass graph-output-record (linear-output-record) +(defclass graph-output-record (standard-sequence-output-record) ((orientation :initarg :orientation) (generation-separation :initarg :generation-separation) (within-generation-separation :initarg :within-generation-separation) @@ -18,14 +18,14 @@ ;;--- This really needs its own AUGMENT-DRAW-SET method. (defmethod elements-never-overlap-p ((record graph-output-record)) t) -(defclass graph-node-output-record (linear-output-record) +(defclass graph-node-output-record (standard-sequence-output-record) ((node-children :accessor graph-node-children) (node-parent :accessor graph-node-parent)) (:default-initargs :size 5)) (define-output-record-constructor graph-node-output-record - (&key x-position y-position (size 25)) - :x-position x-position :y-position y-position :size size) + (&key (size 25)) + :size size) ;;; (Copy of the comment in table-formatting) ;;; Cells have been positioned manually, probably. @@ -184,10 +184,11 @@ (defun layout-graph-edges (graph stream) (let ((orientation (slot-value graph 'orientation))) (with-output-recording-options (stream :draw-p nil :record-p t) - (with-new-output-record (stream 'linear-output-record nil + (with-new-output-record (stream 'standard-sequence-output-record nil :parent graph) (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates + (values 0 0) + #+ignore(convert-from-relative-to-absolute-coordinates stream (output-record-parent graph)) (labels ((draw-edges (parent) (multiple-value-bind (parent-x parent-y) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 6df4b8f4..ba4e2dae 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -101,7 +101,7 @@ (defmethod stream-set-cursor-position* :after ((stream input-protocol-mixin) x y) - (when (minusp x) (break "dunno")) + (when (minusp x) (warn "negative cursor x")) (let ((cursor (stream-text-cursor stream))) (when cursor (entity-set-position cursor x y)))) @@ -450,7 +450,10 @@ ;;; Ok, there's still an issue. Just how do we want to handle this, given ;;; that it's non-trivial to turn a character back into a key-press event. ;;; This issue is still pending. -#+Ignore + +(warn "bogus") +(defparameter *abort-characters* '(#\control-z #\^z)) + (defmethod receive-gesture :around ((stream input-protocol-mixin) (gesture character)) (when (member gesture *abort-characters*) (abort)) diff --git a/clim/menus.lisp b/clim/menus.lisp index ed883b0d..66d2e4a2 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -256,7 +256,7 @@ (cond ((and old-output-history-info (setq old-menu-contents (pop old-output-history-info)) (funcall cache-value-test old-output-history-info cache-value)) - (add-output-record menu old-menu-contents)) + (stream-add-output-record menu old-menu-contents)) (t ;; "Draw" into deexposed menu for sizing only (with-output-recording-options (menu :draw-p nil :record-p t) @@ -470,5 +470,25 @@ (setf y (max min-y (min y (- max-y height)))))) (move-frame frame x y))) +(warn "where should these be") + (defmethod clim-internals::window-refresh (window) (warn "What does this do???")) + + +(defmethod window-viewport-position* (window) + (bounding-rectangle* + (pane-viewport-region window))) + + +(defmethod window-set-viewport-position* (window x y) + (scroll-extent window :x x :y y)) + +(defmethod window-inside-size (window) + (bounding-rectangle-size (pane-viewport-region window))) + +(defun windowp (x) + (typep x 'silica::sheet)) + +(defmethod (setf window-label) (nv window) + nil) diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index c2b91688..10882dc4 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -57,7 +57,8 @@ :accessor stream-end-of-page-action) (text-margin :initarg :text-margin) - (default-text-margin :accessor stream-default-text-margin) + (default-text-margin :accessor stream-default-text-margin + :initform most-positive-fixnum) ;; TSTYLE ;; delete these diff --git a/clim/output-recording-defs.lisp b/clim/output-recording-defs.lisp index fdf2f466..2d030bd5 100644 --- a/clim/output-recording-defs.lisp +++ b/clim/output-recording-defs.lisp @@ -22,7 +22,10 @@ (defmacro define-output-recorder (class medium-graphics-function* medium-components &key points-to-transform + point-sequences-to-transform bounding-rectangle + distances-to-transform + points-not-to-move (superclasses '(graphics-displayed-output-record))) (let ((function-args (get medium-graphics-function* 'silica::args))) `(progn @@ -36,6 +39,12 @@ (when (stream-record-p medium) ;; Transform the coordinates + ,@(mapcar #'(lambda (p) + `(setq ,p (transform-point-sequence + (medium-transformation medium) + ,p))) + point-sequences-to-transform) + ,@(do ((p points-to-transform (cddr p)) r) ((null p) @@ -46,6 +55,19 @@ ,(car p) ,(cadr p))) r)) + ,@(do ((p distances-to-transform (cddr p)) + r) + ((null p) + r) + (push `(multiple-value-setq + (,(car p) ,(cadr p)) + (transform-distance (medium-transformation medium) + ,(car p) ,(cadr p))) + r)) + + + + (let ((rec (make-instance ',class ,@(mapcan #'(lambda (arg) (list (intern arg :keyword) @@ -66,16 +88,20 @@ miny maxx maxy) - + ,@(mapcar #'(lambda (p) + `(with-slots (,p) rec + (setf ,p (adjust-point-sequence ,p minx miny)))) + point-sequences-to-transform) ,@(when points-to-transform `((with-slots ,points-to-transform rec (setf ,@(do ((p points-to-transform (cddr p)) r) ((null p) (nreverse r)) - (push (first p) r) - (push `(- ,(first p) minx) r) - (push (second p) r) - (push `(- ,(second p) miny) r)))))) + (unless (member (car p) points-not-to-move) + (push (first p) r) + (push `(- ,(first p) minx) r) + (push (second p) r) + (push `(- ,(second p) miny) r))))))) (multiple-value-bind (cursor-x cursor-y) @@ -94,24 +120,34 @@ (minx miny) (bounding-rectangle-position* rec) (with-slots (,@function-args ,@medium-components) rec - (silica::with-drawing-options - (stream ,@(mapcan #'(lambda (medium-component) - (list (intern medium-component :keyword) - medium-component)) - medium-components)) - - (let ,(mapcar #'(lambda (p) - (list p p)) - points-to-transform) - (setf ,@(do ((p points-to-transform (cddr p)) - r) - ((null p) (nreverse r)) - (push (first p) r) - (push `(+ ,(first p) minx) r) - (push (second p) r) - (push `(+ ,(second p) miny) r))) - (with-sheet-medium (medium stream) - (,medium-graphics-function* medium ,@function-args))))))) + (letf-globally (( (medium-transformation stream) +identity-transformation+)) + (silica::with-drawing-options + (stream ,@(mapcan #'(lambda (medium-component) + (list (intern medium-component :keyword) + medium-component)) + medium-components)) + + (let (,@(mapcar #'(lambda (p) + (list p p)) + points-to-transform) + ,@(mapcar #'(lambda (p) + (list p p)) + point-sequences-to-transform)) + ,@(mapcar #'(lambda (p) + `(setq ,p + (adjust-point-sequence ,p (- + minx) (- miny)))) + point-sequences-to-transform) + (setf ,@(do ((p points-to-transform (cddr p)) + r) + ((null p) (nreverse r)) + (unless (member (car p) points-not-to-move) + (push (first p) r) + (push `(+ ,(first p) minx) r) + (push (second p) r) + (push `(+ ,(second p) miny) r)))) + (with-sheet-medium (medium stream) + (,medium-graphics-function* medium ,@function-args)))))))) #+ignore (defmethod output-record-refined-sensitivity-test ()) @@ -126,8 +162,94 @@ (min from-y to-y) (max from-x to-x) (max from-y to-y))) - -;; draw-rectangle* + +;;; This is all kind of broken because of the weirdness concerning the +;;; radius-1/2-dx/y stuff. They are vectors that are center relative +;;; Perhaps they just want to be scaled rather than translated. + +(define-output-recorder ellipse-output-record + silica::medium-draw-ellipse* (ink line-style) + :points-to-transform silica::(center-x + center-y + ) + ;; When we move the output record these do not move! + ;; kuldge + :distances-to-transform silica::(radius-1-dx radius-1-dy + radius-2-dx + radius-2-dy) + + :bounding-rectangle + silica::(clim-utils::elliptical-arc-box + center-x + center-y + radius-1-dx + radius-1-dy + radius-2-dx + radius-2-dy + start-angle + end-angle + (silica::line-style-thickness (silica::medium-line-style medium)))) + +(define-output-recorder rectangle-output-record + silica::medium-draw-rectangle* (ink line-style) + :points-to-transform silica::(from-x from-y to-x to-y) + :bounding-rectangle + silica::(values (min from-x to-x) + (min from-y to-y) + (max from-x to-x) + (max from-y to-y))) + + + +(define-output-recorder polygon-output-record + silica::medium-draw-polygon* (ink line-style) + :point-sequences-to-transform silica::(list-of-x-and-ys) + :bounding-rectangle + silica::(point-sequence-bounding-rectangle list-of-x-and-ys)) + + + ;; etc etc +(defun map-point-sequence (fn list-of-x-and-ys) + (do ((p list-of-x-and-ys (cddr p))) + ((null p)) + (funcall fn (car p) (cadr p)))) + +(defun transform-point-sequence (transformation list-of-x-and-ys) + (let (r) + (map-point-sequence + #'(lambda (x y) + (multiple-value-setq + (x y) + (transform-point* transformation x y)) + (push x r) + (push y r)) + list-of-x-and-ys) + (nreverse r))) + +(defun adjust-point-sequence (list-of-x-and-ys dx dy) + (let (r) + (map-point-sequence + #'(lambda (x y) + (push (- x dx) r) + (push (- y dy) r)) + list-of-x-and-ys) + (nreverse r))) + +(defun silica::point-sequence-bounding-rectangle (list-of-x-and-ys) + (let* ((minx (car list-of-x-and-ys)) + (miny (second list-of-x-and-ys)) + (maxx minx) + (maxy miny)) + (map-point-sequence + #'(lambda (x y) + (minf minx x) + (minf miny y) + (maxf maxx x) + (maxf maxy y)) + list-of-x-and-ys) + (values minx miny maxx maxy))) + + diff --git a/clim/stream-defprotocols.lisp b/clim/stream-defprotocols.lisp index 5a678cf7..e899d0da 100644 --- a/clim/stream-defprotocols.lisp +++ b/clim/stream-defprotocols.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: stream-defprotocols.lisp,v 1.7 91/08/05 14:35:33 cer Exp $ +;; $fiHeader: stream-defprotocols.lisp,v 1.1 91/11/25 10:01:16 cer Exp Locker: cer $ (in-package :clim) @@ -309,7 +309,26 @@ Copyright (c) 1991, Franz Inc. All rights reserved ((stream drawing-state-mixin) function &rest x)) (defoperation silica::medium-draw-line* drawing-state-mixin - ((stream drawing-state-mixin) from-x from-y to-x to-y)) + ((stream drawing-state-mixin) from-x from-y to-x to-y)) + +(defoperation silica::medium-draw-polygon* drawing-state-mixin + ((stream drawing-state-mixin) list-of-x-and-ys closed filled)) + +(defoperation silica::medium-draw-ellipse* drawing-state-mixin + ((stream drawing-state-mixin) center-x center-y + radius-1-dx + radius-1-dy + radius-2-dx + radius-2-dy + start-angle + end-angle + filled)) + +(defoperation silica::medium-draw-rectangle* drawing-state-mixin + ((stream drawing-state-mixin) from-x from-y to-x to-y filled)) + + + diff --git a/clim/surround-output.lisp b/clim/surround-output.lisp index a3330d34..8f6b3223 100644 --- a/clim/surround-output.lisp +++ b/clim/surround-output.lisp @@ -1,6 +1,6 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*- +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: clim; Base: 10; Lowercase: Yes -*- -;; $fiHeader: surround-output.lisp,v 1.3 91/08/05 14:35:37 cer Exp $ +;; $fiHeader: surround-output.cl,v 1.1 91/12/17 13:38:51 cer Exp Locker: cer $ (in-package :clim) @@ -33,12 +33,12 @@ (setq *border-shape-drawer-alist* (nconc *border-shape-drawer-alist* (list (list ',shape ',name)))))))))) -(defclass border-output-record (linear-output-record) +(defclass border-output-record (standard-sequence-output-record) ((shape :initarg :shape))) (define-output-record-constructor border-output-record - (&key x-position y-position (size 5) shape) - :x-position x-position :y-position y-position :size size :shape shape) + (&key (size 5) shape) + :size size :shape shape) (define-border-type :rectangle (stream left top right bottom) @@ -68,6 +68,7 @@ (draw-line* stream left top right top))) ;; SURROUNDING-OUTPUT-WITH-BORDER macro in FORMATTED-OUTPUT-DEFS + (defun surrounding-output-with-border-1 (stream shape continuation &key (move-cursor t)) (let* ((body nil) ;the record containing the body (border-record ;the entire bordered output record @@ -76,12 +77,16 @@ (setq body (with-output-to-output-record (stream) (funcall continuation stream)))))) (with-bounding-rectangle* (left top right bottom) body - (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates - stream (output-record-parent (output-record-parent body))) - (translate-fixnum-positions xoff yoff left top right bottom)) + + #+ignore-should-do-something? + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent (output-record-parent body))) + (translate-fixnum-positions xoff yoff left top right + bottom)) + (with-output-recording-options (stream :draw-p nil :record-p t) - (with-new-output-record (stream 'linear-output-record nil + (with-new-output-record (stream 'standard-sequence-output-record nil :parent border-record) (if (funcallable-p shape) (funcall shape stream body left top right bottom) diff --git a/clim/sysdcl.lisp b/clim/sysdcl.lisp index 40053eee..4005f94f 100644 --- a/clim/sysdcl.lisp +++ b/clim/sysdcl.lisp @@ -98,6 +98,8 @@ :load-before-compile ("clim-defs" "incremental-redisplay")) ("menus") + ("surround-output") + ("graph-formatting") ("text-formatting") ("stream-trampolines" :load-before-compile ("defprotocol" "stream-defprotocols") diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp index b9c53748..2c383484 100644 --- a/clim/table-formatting.lisp +++ b/clim/table-formatting.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: table-formatting.lisp,v 1.9 91/08/05 14:35:38 cer Exp $ +;; $fiHeader: table-formatting.lisp,v 1.1 91/11/25 10:01:17 cer Exp Locker: cer $ (in-package :clim) @@ -468,31 +468,37 @@ Copyright (c) 1991, Franz Inc. All rights reserved multiple-columns multiple-columns-inter-column-spacing equalize-column-widths (move-cursor t)) - (let ((table (with-new-output-record (stream record-type nil - :inter-row-spacing - (or (process-spacing-arg stream inter-row-spacing - 'formatting-table - ':inter-row-spacing) - (stream-vsp stream)) - :inter-column-spacing - (or (process-spacing-arg stream inter-column-spacing - 'formatting-table - ':inter-column-spacing) - (stream-string-width stream " ")) - :equalize-column-widths equalize-column-widths) - (with-output-recording-options (stream :draw-p nil :record-p t) - (with-end-of-line-action (:allow stream) - (with-end-of-page-action (:allow stream) - (funcall continuation stream))))))) - (adjust-table-cells table) - (when multiple-columns - (adjust-multiple-columns table stream - (and (numberp multiple-columns) multiple-columns) - (and multiple-columns multiple-columns-inter-column-spacing))) - (replay table stream) - (when move-cursor - (move-cursor-beyond-output-record stream table)) - table)) + (multiple-value-bind + (x y) + (stream-cursor-position* stream) + (let ((table (with-new-output-record (stream record-type nil + :inter-row-spacing + (or (process-spacing-arg stream inter-row-spacing + 'formatting-table + ':inter-row-spacing) + (stream-vsp stream)) + :inter-column-spacing + (or (process-spacing-arg stream inter-column-spacing + 'formatting-table + ':inter-column-spacing) + (stream-string-width stream " ")) + :equalize-column-widths equalize-column-widths) + (with-output-recording-options (stream :draw-p nil :record-p t) + (with-end-of-line-action (:allow stream) + (with-end-of-page-action (:allow stream) + (funcall continuation stream))))))) + (adjust-table-cells table) + (when multiple-columns + (adjust-multiple-columns table stream + (and (numberp multiple-columns) multiple-columns) + (and multiple-columns + multiple-columns-inter-column-spacing))) + ;; Added ?? + (output-record-set-position* table x y) + (replay table stream) + (when move-cursor + (move-cursor-beyond-output-record stream table)) + table))) ;; FORMATTING-CELL macro in FORMATTED-OUTPUT-DEFS (defmethod formatting-cell-internal ((stream output-protocol-mixin) continuation @@ -759,29 +765,33 @@ Copyright (c) 1991, Franz Inc. All rights reserved max-width max-height stream-width stream-height (move-cursor t)) - (let ((menu (with-new-output-record (stream record-type nil - :n-columns n-columns :n-rows n-rows - :max-width max-width :max-height max-height - :stream-width stream-width :stream-height stream-height - :inter-row-spacing - (or (process-spacing-arg stream inter-row-spacing - 'formatting-item-list - ':inter-row-spacing) - (stream-vsp stream)) - :inter-column-spacing - (process-spacing-arg stream inter-column-spacing - 'formatting-item-list - ':inter-column-spacing) - :no-initial-spacing no-initial-spacing) - (with-output-recording-options (stream :draw-p nil :record-p t) - (with-end-of-line-action (:allow stream) - (with-end-of-page-action (:allow stream) - (funcall continuation stream))))))) - (adjust-table-cells menu) - (replay menu stream) - (when move-cursor - (move-cursor-beyond-output-record stream menu)) - menu)) + (multiple-value-bind + (x y) + (stream-cursor-position* stream) + (let ((menu (with-new-output-record (stream record-type nil + :n-columns n-columns :n-rows n-rows + :max-width max-width :max-height max-height + :stream-width stream-width :stream-height stream-height + :inter-row-spacing + (or (process-spacing-arg stream inter-row-spacing + 'formatting-item-list + ':inter-row-spacing) + (stream-vsp stream)) + :inter-column-spacing + (process-spacing-arg stream inter-column-spacing + 'formatting-item-list + ':inter-column-spacing) + :no-initial-spacing no-initial-spacing) + (with-output-recording-options (stream :draw-p nil :record-p t) + (with-end-of-line-action (:allow stream) + (with-end-of-page-action (:allow stream) + (funcall continuation stream))))))) + (adjust-table-cells menu) + #+ignoremaybe(output-record-set-position* menu x y) + (replay menu stream) + (when move-cursor + (move-cursor-beyond-output-record stream menu)) + menu))) (defun format-items (item-list &key (stream *standard-output*) printer presentation-type inter-row-spacing inter-column-spacing diff --git a/clim/text-output-recording.lisp b/clim/text-output-recording.lisp index c0489880..dac1b013 100644 --- a/clim/text-output-recording.lisp +++ b/clim/text-output-recording.lisp @@ -101,6 +101,7 @@ (color (slot-value record 'ink))) (declare (fixnum start end baseline)) (with-sheet-medium (medium stream) + (letf-globally (( (medium-transformation medium) +identity-transformation+)) (macrolet ((do-it (end-position) `(loop @@ -135,7 +136,7 @@ (incf start)))))) (multiple-value-bind (cursor-x cursor-y) (output-record-position* record) (declare (fixnum cursor-x cursor-y)) - (do-it end)))))) + (do-it end))))))) (defmethod replay-output-record ((record styled-text-displayed-output-record) stream &optional region) (declare (ignore region)) @@ -148,6 +149,7 @@ (color (slot-value record 'ink))) (declare (fixnum start end baseline)) (with-sheet-medium (medium stream) + (letf-globally (( (medium-transformation medium) +identity-transformation+)) (macrolet ((do-it (end-position) `(loop @@ -186,7 +188,7 @@ (do-it change-position) (setf text-style new-text-style start change-position))) - (do-it end)))))) + (do-it end))))))) (defmethod add-string-output-to-text-record ((record text-displayed-output-record) text-string start end text-style @@ -342,7 +344,12 @@ (slot-value match 'text-style-changes))) (setf (output-record-contents-ok text) t) ;; make sure that old bounding-rect is the same relative position from - ;; old-start-position as the bounding-rect is from start-position + ;; old-start-position as the bounding-rect is from + ;; start-position + (multiple-value-bind (old-start-x old-start-y) + (bounding-rectangle-position* match) + (output-record-set-old-start-position* text old-start-x old-start-y)) + #+ignore (multiple-value-bind (delta-x delta-y) (multiple-value-bind (ex ey) (bounding-rectangle-position* text) (declare (fixnum ex ey)) @@ -362,23 +369,22 @@ (let ((baseline 0) (style (medium-default-text-style stream))) (declare (fixnum baseline)) - (labels ((find-or-recurse (element y-offset) - (declare (fixnum y-offset)) + (labels ((find-or-recurse (element) (typecase element (styled-text-displayed-output-record - (maxf baseline (the fixnum (+ y-offset (slot-value element 'baseline))))) + (maxf baseline (the fixnum (+ (bounding-rectangle-min-y element) (slot-value element 'baseline))))) (text-displayed-output-record (maxf baseline - (the fixnum (+ y-offset (- (text-style-height style stream) + (the fixnum (+ (bounding-rectangle-min-y element) + (- (text-style-height style stream) (text-style-descent style stream)))))) (t - (multiple-value-bind (xoff yoff) (output-record-position* element) - (declare (fixnum yoff)) - (declare (ignore xoff)) - (map-over-output-record-elements element - #'find-or-recurse 0 0 (the fixnum (+ yoff y-offset)))))))) + (map-over-output-record-children + #'find-or-recurse + element + +everywhere+))))) (declare (dynamic-extent #'find-or-recurse)) - (find-or-recurse record 0)) + (find-or-recurse record)) baseline)) diff --git a/misc/go.lisp b/misc/go.lisp index dd334642..bbe93ba4 100644 --- a/misc/go.lisp +++ b/misc/go.lisp @@ -51,10 +51,6 @@ (defsys::compile-system :xm-silica) (defsys::load-system :xm-silica) -;(load "ws/sysdcl") -;(defsys::compile-system :ws) -;(defsys::load-system :ws) - (defsys::compile-system :xm-ws) (defsys::load-system :xm-ws) @@ -64,3 +60,7 @@ ) (load "test/test") + +(excl::compile-file-if-needed "test/test-suite") +(load "test/test-suite") + diff --git a/notes/plan.todo b/notes/plan.todo index 0f0ed47f..9634ec46 100644 --- a/notes/plan.todo +++ b/notes/plan.todo @@ -6,7 +6,6 @@ % Xtk * Support for CLIM [1w] - % Xm * Tidy up [2w] @@ -28,16 +27,11 @@ * General tidying up [2w] - Spec conformance - names etc -== 14weeks - -%%% Part 2 +Total = 14weeks -% Xlib - * CLX level support [4w] - -% Xtk - * Full interface [2w] +================================================ +%%% % OLIT * Implement for CLIM [1w] @@ -46,9 +40,6 @@ % Silica * OLIT [1w] -== 10weeks - - % CLIM the next generation * Accept <-> gadget interface @@ -58,110 +49,13 @@ * Support for programming in motif * Support for programming in OpenLook --------------------------------------------------- -% CLIM issues - * Output protocol - - * Mirror geometry protocol - - * Scroller, viewport protocol - - * Keyboard events - - Keyboard focus in widgets. - - Keysym translation - - NEED to look at sources - - * Repaint - - clipping region and redrawing the background - - weird ensure-cursor-visible-behavior - - * application frames - - Just take the 0.9 layout stuff - - + some mechanism for defining - - command-menus. - + We can create a menu bar and generate items for it. One - problem is that they will always be sensitive even when the - input context is not for a command. There seems no easy way of - doing this. I guess they generate a command-event that gets - executed at some point. - - clim-interactor has a display-function slot? and when that is - non NIL we invoke it after a command? - - Perhaps CLIM panes do a compose-space by running - * menus - * accepting-values and gadgets - -% ff issues - * templates for def-c-type accessors - * templates for foreign function stuff - * specify arg-names for the foreign function arglist - * Efficient generation of CLOS <-> address mapping - - We want to have type checking - - we want stub code to be compact. - - How about doing inline stuff. - * Arg checking. - - I really want to specify the names of the arguments but I do not - want to do any checking. - -% Xlib interface - * generate xlib.h.lisp - * provide CLOS wrappers for Objects - * implement function interface - * Silica need not use the wrappers - -% Xt interface - * generate intrinsics.h.lisp - * provide CLOS wrappers for objects - * implement function interface - - * issues - - graphics - - events - - font accessors - - images - - cursors - - misc accessors for displays, screens etc - - window operations - - graphics - + finished encode/decode - - initialization - - type checking in convertors - - implement CLX functionality. - -% xtk - * Event Handlers - * Finish callbacks - * Convenience functions - * timers and mp - * alternative input - * initialization - * type checking in resources convertors - -% xm - * Generate class definitions - * Interface to Xmu/UIL - -% ol - * Generate class definitions - * Interface to devGuide UIL - -% Extensive implementation of silica - * graphics - - perhaps we can steal the code from clx-implementation - -% Windshield - * Frames, generic gadget protocol - -% Motif specific application frame level - * Perhaps we just define all of the gadgets and start using them - -% Adaptive toolkit level - * This bit seems OK except for the lack of integration between - gadgets and commands etc. However, it is important for windows to - be designed with a GUI-BUILDER and used from within CLIM - - * The notion of callbacks just being generic functions seems bad. - -% Rest is up to swm +==================================================== +%%%%%%%%%%%%%%%%%%%% &optional stuff +% Xlib + * CLX level support [4w] + +% Xtk + * Full interface [2w] diff --git a/silica/classes.lisp b/silica/classes.lisp index f91a3c60..4c5ffa28 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) (defclass port () ((server-path :reader port-server-path) diff --git a/silica/clim.lisp b/silica/clim.lisp index 5e55521f..95cb5b9a 100644 --- a/silica/clim.lisp +++ b/silica/clim.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) (defclass clim-sheet (sheet diff --git a/silica/db-box.lisp b/silica/db-box.lisp index 9dddfd63..4f6dc969 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -28,11 +28,9 @@ ;;; Boxing Panes ;;; -(defclass box-pane (mute-input-mixin - pane-background-mixin - composite-pane - #+ignore list-contents-mixin - space-req-cache-mixin) + + +(defclass box-pane (layout-pane) ((space :initform 1 :initarg :space) contents)) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index 69419c69..fcf233a0 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -147,20 +147,55 @@ ;;; (defclass space-req-mixin (layout-mixin) - ((space-req :reader pane-space-req))) + ((initial-space-req :reader pane-initial-space-req) + (space-req :reader pane-space-req))) (defmethod initialize-instance :after ((pane space-req-mixin) + &rest args &key - (width 0) (max-width width) (min-width width) - (height 0) (max-height height) (min-height height)) - (setf (slot-value pane 'space-req) - (make-space-req :width width - :height height - :max-width max-width - :min-width min-width - :max-height max-height - :min-height min-height))) + width max-width min-width + height max-height min-height) + (declare (ignore width min-width max-width + height min-height max-height)) + (multiple-value-bind + (width min-width max-width + height min-height max-height) + (apply #'default-space-requirements + pane + :allow-other-keys t + args) + (setf (slot-value pane 'space-req) + (make-space-req :width width + :height height + :max-width max-width + :min-width min-width + :max-height max-height + :min-height min-height) + (slot-value pane 'initial-space-req) + (make-space-req :width width + :height height + :max-width max-width + :min-width min-width + :max-height max-height + :min-height min-height)))) + +(defmethod default-space-requirements ((pane space-req-mixin) + &key + (width 0) + (min-width width) + (max-width width) + (height 0) + (min-height height) + (max-height height)) + (values width + min-width + max-width + height + min-height + max-height)) + + (defmethod compose-space ((pane space-req-mixin)) (slot-value pane 'space-req)) @@ -190,7 +225,7 @@ :max-height (or max-height height +fill+) :min-height (or min-height height 0))))) -(defmethod compose-space ((pane client-space-req-mixin)) +(defmethod compose-space :around ((pane client-space-req-mixin)) (or (slot-value pane 'client-space-req) (call-next-method))) @@ -306,10 +341,10 @@ (clear-space-req-cache pane)) (defun clear-space-req-caches-in-tree (sheet) - (walk-tree #'(lambda (sheet depth nth) - (declare (ignore depth nth)) - (clear-space-req-cache sheet)) - sheet)) + (clim-internals::map-over-sheets + #'(lambda (sheet) + (clear-space-req-cache sheet)) + sheet)) (defun clear-space-req-caching-in-ancestors (menu) (do ((parent (sheet-parent menu) (sheet-parent parent))) @@ -427,3 +462,13 @@ (decf extra used)) (push alloc sizes))) (nreverse sizes)))) + +;;; Most of the layout panes should inherit from this + +(defclass layout-pane (mute-input-mixin + pane-background-mixin + composite-pane + space-req-cache-mixin + sheet-permanently-enabled-mixin) + ()) + diff --git a/silica/db-table.lisp b/silica/db-table.lisp index b562e6d0..50c64a4a 100644 --- a/silica/db-table.lisp +++ b/silica/db-table.lisp @@ -30,10 +30,7 @@ -(defclass table-pane (mute-input-mixin - pane-background-mixin - composite-pane - space-req-cache-mixin) +(defclass table-pane (layout-pane) (row-space-reqs column-space-reqs contents)) @@ -74,7 +71,7 @@ (dotimes (row (array-dimension contents 0)) (let ((min-h 0) (h 0) - (max-h 0)) + (max-h nil)) (dotimes (column (array-dimension contents 1)) (let ((item (aref contents row column))) (when item @@ -82,7 +79,10 @@ ;; Max the heights (maxf h (space-req-height isr)) (maxf min-h (space-req-min-height isr)) - (maxf max-h (space-req-max-height isr)))))) + ;; should this be min or max + (if max-h + (minf max-h (space-req-max-height isr)) + (setf max-h (space-req-max-height isr))))))) (push (make-space-req @@ -102,7 +102,7 @@ (dotimes (column (array-dimension contents 1)) (let ((min-w 0) (w 0) - (max-w 0)) + (max-w nil)) (dotimes (row (array-dimension contents 0)) (let ((item (aref contents row column))) @@ -111,7 +111,10 @@ ;; Max the widths (maxf w (space-req-width isr)) (maxf min-w (space-req-min-width isr)) - (maxf max-w (space-req-max-width isr)))))) + ;; Should this be min or max??? + (if max-w + (minf max-w (space-req-max-width isr)) + (setf max-w (space-req-max-width isr))))))) (push (make-space-req diff --git a/silica/defsys.lisp b/silica/defsys.lisp index 08c52dcb..835e8c4b 100644 --- a/silica/defsys.lisp +++ b/silica/defsys.lisp @@ -1,3 +1,4 @@ +;; -*- mode: common-lisp; package: user -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. @@ -18,6 +19,8 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + (defsystem :silica (:default-pathname ".") (|pkg|) diff --git a/silica/event.lisp b/silica/event.lisp index 35880427..aa3785d4 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) ;;; Event stuff diff --git a/silica/graphics.lisp b/silica/graphics.lisp index dc107d32..630303f6 100644 --- a/silica/graphics.lisp +++ b/silica/graphics.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,10 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) + (defclass sheet-with-graphics-state () ((foreground :initform +black+ :accessor sheet-foreground) @@ -55,6 +59,11 @@ x (push argname unspread-argument-names) (ecase type + (point-sequence + (destructuring-bind + (new-name) names + (push `(unspread-point-sequence ,argname) spread-arguments) + (push new-name spread-argument-names))) (point (destructuring-bind (x y) names @@ -84,7 +93,8 @@ x) 'keyword)) keyword)))) - ) +) ; eval-when + (defmacro define-graphics-function (name arguments &body stuff) (let* ((spread-name (intern (format nil "~A*" name))) @@ -97,7 +107,8 @@ line-thickness line-unit line-dashes - line-cap-shape)) + line-cap-shape + line-joint-shape)) (medium-graphics-function-name (intern (format nil "~A~A*" 'medium- name))) (port-function-name @@ -171,19 +182,28 @@ ;; draw-points ;; draw-polygon +(define-graphics-function draw-polygon ((points point-sequence list-of-x-and-ys) + &key + (closed t) + (filled t))) + + + (define-graphics-function draw-ellipse ((center point center-x center-y) - radius-dx-1 - radius-dy-1 - radius-dx-2 - radius-dy-2 + radius-1-dx + radius-1-dy + radius-2-dx + radius-2-dy &key - (filled t) - start-angle - end-angle)) + (start-angle 0) + (end-angle 2pi) + (filled t))) + +(defun draw-circle (medium center radius &rest args) + (apply #'draw-ellipse medium center 0 radius radius 0 args)) -(define-graphics-function draw-circle ((center point center-x center-y) - radius - &key (filled t))) +(defun draw-circle* (medium center-x center-y radius &rest args) + (apply #'draw-ellipse* medium center-x center-y 0 radius radius 0 args)) (define-graphics-function draw-text (string-or-char (point point x y) diff --git a/silica/medium.lisp b/silica/medium.lisp index d5e7e063..efd27fc1 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) (defmethod engraft-medium (medium port sheet) (declare (ignore sheet port)) @@ -56,7 +59,34 @@ :sheet sheet))) -(defun %make-line-style (&rest x) :line-style) +(defclass line-style () + ((unit :type (member :normal :point) + :initform :normal :initarg :unit + :reader line-style-unit) + (thickness :type real + :initform 1 :initarg :thickness + :reader line-style-thickness) + (joint-shape :type (member :miter :bevel :round :none) + :initform :miter :initarg :joint-shape + :reader line-style-joint-shape) + (cap-shape :type (member :butt :square :round :no-end-point) + :initform :butt :initarg :cap-shape + :reader line-style-cap-shape) + (dashes :initform nil :initarg :dashes + :reader line-style-dashes) + )) + +(defun make-line-style-1 (line-unit line-thickness line-dashes + line-joint-shape line-cap-shape) + (make-instance 'line-style + :unit line-unit + :thickness line-thickness + :dashes line-dashes + :joint-shape line-joint-shape + :cap-shape line-cap-shape)) + +(defun %make-line-style (&rest x) + (apply #'make-instance 'line-style x)) (defmethod invoke-with-drawing-options ((sheet sheet) function &rest options) (declare (dynamic-extent options)) @@ -67,39 +97,115 @@ function options))) + + +(defmethod invoke-with-drawing-options + ((medium medium) continuation + &key ink clipping-region transformation + line-style line-unit line-thickness (line-dashes nil dashes-p) + line-joint-shape line-cap-shape + (text-style nil text-style-p) (text-family nil text-family-p) + (text-face nil text-face-p) (text-size nil text-size-p)) + (with-slots ((medium-ink ink) + (medium-transformation transformation) + (transformed-clipping-region region) + (medium-line-style line-style)) medium + ;; Close the current output record if the drawing ink is changing + #+ignore-do-we-have-to-do-this + (unless (eq medium-ink ink) + (close-current-text-output-record medium)) + (let* ((saved-ink medium-ink) + (saved-transformation medium-transformation) + (saved-clipping-region transformed-clipping-region) + (saved-line-style medium-line-style)) + (unwind-protect + (progn + (when ink + (setf medium-ink ink)) + (when transformation + (setf medium-transformation + (compose-transformations saved-transformation transformation))) + (when clipping-region + (setf transformed-clipping-region + (region-intersection saved-clipping-region + (transform-region medium-transformation + clipping-region)))) + (cond ((or line-unit line-thickness line-joint-shape line-cap-shape dashes-p) + (when (null line-style) + (setf line-style saved-line-style)) + (setf medium-line-style + (make-line-style-1 + (or line-unit (line-style-unit line-style)) + (or line-thickness (line-style-thickness line-style)) + (if dashes-p line-dashes (line-style-dashes line-style)) + (or line-joint-shape (line-style-joint-shape line-style)) + (or line-cap-shape (line-style-cap-shape line-style))))) + (line-style + (setf medium-line-style line-style))) + (when (or text-family-p text-face-p text-size-p) + (if text-style-p + (setq text-style (with-stack-list (style text-family text-face text-size) + (merge-text-styles style text-style))) + (setq text-style (make-text-style text-family text-face text-size) + text-style-p t))) + (if text-style-p + (flet ((call-continuation (stream) + (declare (ignore stream)) + (funcall continuation))) + (declare (dynamic-extent #'call-continuation)) + (with-text-style-internal medium text-style #'call-continuation medium)) + (funcall continuation))) + (setf medium-line-style saved-line-style) + (setf transformed-clipping-region saved-clipping-region) + (setf medium-transformation saved-transformation) + (setf medium-ink saved-ink))))) + +#+ignore (defmethod invoke-with-drawing-options ((medium medium) function + &rest args &key + (line-cap-shape nil line-cap-shape-p) + (line-joint-shape nil line-joint-shape-p) + (line-dashes nil line-dashes-p) (line-thickness nil line-thickness-p) + (line-unit nil line-unit-p) + (line-style nil line-style-p) (ink nil ink-p) - (text-style nil text-style-p) (transformation nil trans-p) (clipping-region nil clipping-region-p) - (line-style nil line-style-p) (text-family nil text-family-p) (text-face nil text-face-p) - (text-size nil text-size-p)) - (when (or text-size-p text-face-p text-family-p line-style-p - clipping-region-p) - (warn "unhandled option to invoke-with-drawing-options")) + (text-size nil text-size-p) + (text-style nil text-style-p)) + + (with-rem-keywords (new args '(:ink :text-style :line-style :transformation)) + (when new + (warn "unhandled option to invoke-with-drawing-options ~S" new))) (let ((old-ink (if ink-p (medium-ink medium))) (old-trans (if trans-p (medium-transformation medium))) - (old-text-style (if text-style-p (medium-text-style medium)))) + (old-text-style (if text-style-p (medium-text-style medium))) + (old-line-style (if line-style-p (medium-line-style medium)))) (unwind-protect (progn (when ink-p (setf (medium-ink medium) ink)) + ;; Should we not compose (when trans-p (setf (medium-transformation medium) transformation)) (when text-style-p (setf (medium-text-style medium) text-style)) + (when line-style-p + (setf (medium-line-style medium) line-style)) (funcall function)) (when ink-p (setf (medium-ink medium) old-ink)) (when trans-p (setf (medium-transformation medium) old-trans)) (when text-style-p - (setf (medium-text-style medium) old-text-style))))) + (setf (medium-text-style medium) old-text-style)) + (when line-style-p + (setf (medium-line-style medium) old-line-style))))) (defmethod allocate-medium (port sheet) (or (pop (port-media-cache port)) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index e98ad1ef..6bd8cbed 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,10 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) + ;;;; sheet-device-transformation - transformation from sheets ;;;; coordinate space to its mirror diff --git a/silica/pkg.lisp b/silica/pkg.lisp index 2d039ba4..a8a294de 100644 --- a/silica/pkg.lisp +++ b/silica/pkg.lisp @@ -1,4 +1,4 @@ -(defpackage :silica +;; -*- mode: common-lisp; package: user -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(defpackage :silica (:use clim-lisp clim-utils) (:export #:*default-text-style* diff --git a/silica/port.lisp b/silica/port.lisp index 4df37f27..e3127f46 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,10 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) + ;; Ports and grafts diff --git a/silica/protocols.lisp b/silica/protocols.lisp index c55dd759..10ce206c 100644 --- a/silica/protocols.lisp +++ b/silica/protocols.lisp @@ -21,6 +21,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; +;; $fiHeader$ (in-package "CLIM-UTILS") diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 2dd6ccca..52ae357b 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) (defmethod bounding-rectangle* ((x sheet)) (bounding-rectangle* (sheet-region x))) diff --git a/silica/std-sheet.lisp b/silica/std-sheet.lisp index 1ec97a51..130ac39d 100644 --- a/silica/std-sheet.lisp +++ b/silica/std-sheet.lisp @@ -1,4 +1,4 @@ -(in-package :silica) +;; -*- mode: common-lisp; package: silica -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,6 +18,9 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :silica) (defclass standard-sheet (sheet mirrored-sheet-mixin @@ -45,4 +48,5 @@ (defmethod handle-event (sheet event) (declare (ignore sheet event)) + #+ignore(warn "ignoring event ~S,~S" sheet event) nil) diff --git a/silica/sysdcl.lisp b/silica/sysdcl.lisp deleted file mode 100644 index a778f8c7..00000000 --- a/silica/sysdcl.lisp +++ /dev/null @@ -1,35 +0,0 @@ - -;; -;; 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 Suppplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -(in-package :cl-user) - -(defsys::defsystem :silica - (:default-pathname (frob-pathname "silica")) - ("pkg") - ("classes") - ("text-style") - ("macros") - ("sheet") - ("mirror") - ("event") - ("port") - ("medium") - ("graphics") - ("std-sheet")) diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 6181e4ff..566de261 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: text-style.lisp,v 1.1 91/08/30 15:16:23 cer Exp $ +;; $fiHeader: text-style.cl,v 1.1 91/11/25 10:01:59 cer Exp Locker: cer $ (in-package :silica) @@ -579,7 +579,20 @@ Copyright (c) 1991, Franz Inc. All rights reserved (if *allow-loose-text-style-size-mapping* (let ((fonts (gethash (list family face) mapping-table))) (setf (gethash (list family face) mapping-table) - (merge 'list fonts (list (list style result)) + (merge 'list + (list (list style result)) + (multiple-value-bind + (a b c) + (text-style-components style) + (delete-if #'(lambda (old) + (multiple-value-bind + (x y z) + (text-style-components + (car old)) + (and (equal x a) + (equal y b) + (= z c)))) + fonts)) #'(lambda (one two) (< (slot-value (car one) 'size) (slot-value (car two) 'size)))))) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 2380ea81..5c96a9ec 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM; Mode: LISP; Lowercase: T -*- -;; $fiHeader: test-suite.cl,v 1.1 91/12/10 16:57:32 cer Exp Locker: cer $ +;; $fiHeader: test-suite.cl,v 1.2 91/12/13 10:36:59 cer Exp Locker: cer $ (in-package :clim) @@ -633,10 +633,32 @@ people, shall not perish from the earth. ,@body)))) (defparameter *basic-shapes* `( - ("Rectangle" draw-rectangle* 0 0 90 100) + ("Rectangle" draw-rectangle* 0 0 90 100) ("Triangle" draw-polygon* (0 0 45 100 100 0)) ("Circle" draw-circle* 50 50 50) - ("Polygon" draw-polygon* (0 0 10 100 50 50 90 100 100 10)))) + ("Polygon" draw-polygon* (0 0 10 100 50 50 90 100 100 10)) + )) + +#+ignore(define-test (basic-graphics-shapes graphics) (stream) + "Test basic graphics shapes" + (formatting-table + (stream) + (formatting-row (stream) + (formatting-cell (stream) + (draw-polygon* stream '(0 0 45 100 + 100 0) :ink +red+))) + (formatting-row (stream) + (formatting-cell (stream) + (draw-rectangle* stream 0 0 90 100) + )) + (formatting-row (stream) + (formatting-cell (stream) + (draw-circle* stream 50 50 50))) + (formatting-row (stream) + (formatting-cell (stream) + (draw-polygon* stream '(0 0 10 100 50 50 90 100 100 10)) + )) + )) (define-test (basic-graphics-shapes graphics) (stream) "Test basic graphics shapes" @@ -1322,6 +1344,8 @@ Luke Luck licks the lakes Luke's duck likes.")) (multiple-value-bind (xoff yoff) ;; damn, we have to convert because we want to draw in table-cell relative ;; coordinates. + (values 0 0) + #+ignore (#-Silica clim::convert-from-absolute-to-relative-coordinates #+Silica ci::convert-from-absolute-to-relative-coordinates stream (output-record-parent record)) @@ -1339,6 +1363,8 @@ Luke Luck licks the lakes Luke's duck likes.")) (multiple-value-bind (xoff yoff) ;; damn, we have to convert because we want to draw in table-cell relative ;; coordinates. + (values 0 0) + #+ignore (#-Silica clim::convert-from-absolute-to-relative-coordinates #+Silica ci::convert-from-absolute-to-relative-coordinates stream (output-record-parent record)) @@ -1930,7 +1956,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (let ((data (clim-utils:with-standard-io-environment (let ((data nil) - (*package* (or (find-package "COMMON-LISP-USER") + (*package* (or (find-package :common-lisp-user) (error "Package COMMON-LISP-USER not found")))) (dolist (name-and-pathname specs) (let* ((short-name (pop name-and-pathname)) @@ -2885,11 +2911,11 @@ Luke Luck licks the lakes Luke's duck likes.")) (:command-definer nil) (:pane (with-slots (caption-pane display-pane) *application-frame* (silica::vertically () - (silica::scrolling - () - (setf caption-pane + (setf caption-pane (silica::realize-pane - 'application-pane))) + 'application-pane + :height 50 + )) (silica::scrolling () (setf display-pane diff --git a/test/test.lisp b/test/test.lisp index e5b95562..52da8762 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -134,3 +134,22 @@ (object) (list object)) + + +(define-application-frame test-frame4 () + (a b c) + (:command-table test-frame) + (:pane + (vertically () + (realize-pane 'silica::push-button :label "Press me") + (realize-pane 'silica::toggle-button) + (realize-pane 'silica::slider) + (realize-pane 'silica::text-field) + (silica::scrolling + () + (silica::realize-pane + 'interactor-pane + :width 300 + :max-width +fill+ + :height 300 + :max-height +fill+))))) diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp index 0835c2d4..02fc91b5 100644 --- a/tk-silica/image.lisp +++ b/tk-silica/image.lisp @@ -1,3 +1,28 @@ +;; -*- 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) diff --git a/tk-silica/pkg.lisp b/tk-silica/pkg.lisp index 9894a092..9272c89a 100644 --- a/tk-silica/pkg.lisp +++ b/tk-silica/pkg.lisp @@ -1,3 +1,4 @@ +;; -*- mode: common-lisp; package: user -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -17,6 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ (defpackage :xm-silica (:use clim-lisp clim-utils silica tk)) diff --git a/tk-silica/sysdcl.lisp b/tk-silica/sysdcl.lisp index 522289bc..24b3c2f2 100644 --- a/tk-silica/sysdcl.lisp +++ b/tk-silica/sysdcl.lisp @@ -1,4 +1,4 @@ -(in-package :cl-user) +;; -*- mode: common-lisp; package: cl-user -*- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -18,12 +18,16 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :cl-user) (defsys::defsystem :xm-silica - (:default-pathname (frob-pathname "xm-silica")) + (:default-pathname (frob-pathname "xm-silica")) ("pkg") ("xm-silica") - ("xm-graphics")) + ("xm-graphics") + ("image")) (defsys::defsystem :xm-ws (:default-pathname (frob-pathname "xm-silica")) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 4e5cbd90..c74e5d1c 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -1,4 +1,4 @@ -(in-package :xm-silica) +;; -*- 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. @@ -18,6 +18,10 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :xm-silica) + (defclass motif-frame-manager (frame-manager) ()) @@ -204,11 +208,24 @@ Can the basic motif stuff support lazy realization? 'frame-wm-protocol-callback frame))) +(defclass window-manager-event (event) + ()) + +(defclass wm-delete-window-event (window-manager-event) + ((sheet :initarg :sheet :reader silica::event-sheet)) + ) + +(defmethod silica::handle-event (sheet (event wm-delete-window-event)) + (clim::frame-exit clim::*application-frame*)) + (defun frame-wm-protocol-callback (widget frame) ;; Invoked when the Wm close function has been selected ;; We want to queue an "event" somewhere so that we can ;; synchronously quit from the frame - ) + (distribute-event + (port frame) + (make-instance 'wm-delete-window-event + :sheet (frame-top-level-sheet frame)))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index c9cfc3af..ccfb6d25 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -29,11 +29,11 @@ (push-button motif-push-button) (canvas motif-drawing-area) (text-field motif-text-field) - (toggle-button - motif-toggle-button) + (toggle-button motif-toggle-button) (silica::menubar motif-menubar) - ;;; One day (silica::viewport xm-viewport) + + ;; One day (line-editor-pane) (label-button-pane) (radio-button-pane) @@ -229,7 +229,7 @@ (defclass motif-scrollbar (motif-leaf-pane silica::sheet-permanently-enabled-mixin gadget - #+ignore motif-value-pane) + silica::scrollbar) ((orientation :initarg :orientation)) (:default-initargs :orientation :horizontal)) @@ -344,8 +344,8 @@ sheet)) (defmethod allocate-space ((sheet motif-top-level-sheet) width height) - (allocate-space (car (sheet-children sheet)) width - height)) + (silica::resize-sheet* (car (sheet-children sheet)) + width height)) (defmethod compose-space ((sheet motif-top-level-sheet)) (compose-space (car (sheet-children sheet)))) @@ -529,6 +529,10 @@ (setf (slot-value vp 'viewport) (make-bounding-rectangle 0 0 (sheet-width vp) (sheet-height vp)))) +(defmethod allocate-space ((vp xm-viewport) width height) + ;; We do nothing to the child of a viewport + nil) + (defmethod allocate-space :after ((vp xm-viewport) width height) (bounding-rectangle-set-size (silica::xm-viewport-viewport vp) @@ -559,11 +563,11 @@ '(:scrolling-policy :application-defined :scroll-bar-display-policy :static))) - -(defmethod realize-mirror :around ((port motif-port) (sheet xm-viewport)) - (let* ((m (call-next-method))) - (tk::set-values (sheet-mirror (silica::sheet-parent sheet)) :work-window m) - m)) +; From the days when the parent used to be a motif scroll window +;(defmethod realize-mirror :around ((port motif-port) (sheet xm-viewport)) +; (let* ((m (call-next-method))) +; (tk::set-values (sheet-mirror (silica::sheet-parent sheet)) :work-window m) +; m)) (defmethod add-sheet-callbacks ((port motif-port) (sheet xm-viewport) widget) @@ -616,16 +620,19 @@ (clim::pane-scroller-sheet x)) (defun clim::update-region (stream width height &key no-repaint) - (setf (sheet-region stream) - (make-bounding-rectangle 0 0 - (max (bounding-rectangle-width stream) width) - (max (bounding-rectangle-height stream) height)))) + (when (or (> width (bounding-rectangle-width stream)) + (> height (bounding-rectangle-height stream))) + (setf (sheet-region stream) + (make-bounding-rectangle 0 0 + (max (bounding-rectangle-width stream) width) + (max (bounding-rectangle-height stream) height))))) (defun clim::scroll-extent (stream &key (x 0) (y 0)) ;; This should copy-area and then do a repaint of the new stuff. ;; Perhaps for the time being we can just clear the current area and ;; then repaint the whole thing + #+ignore-why-is-this-here (setq y (min y (max (- (bounding-rectangle-height stream) (bounding-rectangle-height (clim::pane-viewport stream))) diff --git a/tk-silica/xm-graphics.lisp b/tk-silica/xm-graphics.lisp index f4824f18..26ac891c 100644 --- a/tk-silica/xm-graphics.lisp +++ b/tk-silica/xm-graphics.lisp @@ -1,4 +1,4 @@ -(in-package :xm-silica) +;; -*- 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. @@ -18,6 +18,10 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :xm-silica) + (defmethod make-medium ((port motif-port) sheet) (make-instance 'motif-medium @@ -64,7 +68,6 @@ (tk::gcontext-foreground flipping-gcontext) (logxor foreground-pixel background-pixel))))) - (defmethod (setf medium-background) :after (ink (medium motif-medium)) @@ -104,26 +107,39 @@ (defmethod clx-decode-ink ((ink contrasting-ink) stream) (clx-decode-ink (make-color-for-contrasting-ink ink) stream)) -(defmethod clx-decode-color :around ((medium motif-medium) color) - (or (gethash color (port-color-cache (port medium))) - (setf (gethash color (port-color-cache (port medium))) - (call-next-method)))) + + +(defmethod clx-decode-color ((medium motif-medium) (x (eql +foreground+))) + (with-slots (foreground-gcontext) medium + (tk::gcontext-foreground foreground-gcontext))) + +(defmethod clx-decode-color ((medium motif-medium) (x (eql +background+))) + (with-slots (background-gcontext) medium + (tk::gcontext-foreground background-gcontext))) + + +(defmethod clx-decode-color ((stream motif-medium) (ink standard-opacity)) + (if (> (slot-value ink 'clim-utils::value) 0.5) + (clx-decode-color stream +foreground+) + (clx-decode-color stream +background+))) (defmethod clx-decode-color ((medium motif-medium) (ink color)) - (multiple-value-bind - (red green blue) - (color-rgb ink) - (tk::allocate-color - (tk::default-colormap (port-display (port medium))) - (make-instance 'tk::color - :red (truncate (* 65356 red)) - :green (truncate (* 65356 green)) - :blue (truncate (* 65356 blue)))))) - - -(defmethod clx-adjust-ink ((medium motif-medium) gc ink line-style) + (or (gethash ink (port-color-cache (port medium))) + (setf (gethash ink (port-color-cache (port medium))) + (multiple-value-bind + (red green blue) + (color-rgb ink) + (tk::allocate-color + (tk::default-colormap (port-display (port medium))) + (make-instance 'tk::color + :red (truncate (* 65356 red)) + :green (truncate (* 65356 green)) + :blue (truncate (* 65356 blue)))))))) + + +(defmethod clx-adjust-ink ((medium motif-medium) gc ink line-style x-origin y-origin) ;; This is used to adjust for the line-style - (declare (ignore ink line-style)) + (declare (ignore ink)) (let ((thickness (silica::line-style-thickness line-style))) (if (< thickness 2) @@ -142,6 +158,12 @@ ((:miter :none) :miter) (:bevel :bevel) (:round :round))) + + + (when (eq (tk::gcontext-fill-style gc) :tiled) + (setf (tk::gcontext-ts-x-origin gc) x-origin + (tk::gcontext-ts-y-origin gc) y-origin)) + gc) (defmethod clx-decode-ink :around ((ink t) (medium motif-medium)) @@ -165,6 +187,11 @@ (transform-point* transform x y)) (values (truncate x) (truncate y))) +(defun devicize-distance (transform x y) + (multiple-value-setq (x y) + (transform-distance transform x y)) + (values (truncate x) (truncate y))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -182,7 +209,9 @@ (clx-adjust-ink medium (clx-decode-ink (medium-ink medium) medium) (medium-ink medium) - (medium-line-style medium)) + (medium-line-style medium) + (min x1 x2) + (min y1 y2)) x1 y1 x2 @@ -203,9 +232,11 @@ (tk::draw-rectangle (tk::widget-window (sheet-mirror sheet)) (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium)) + (clx-decode-ink (medium-ink medium) medium) + (medium-ink medium) + (medium-line-style medium) + (min x1 x2) + (min y1 y2)) (min x1 x2) (min y1 y2) (abs (- x2 x1)) @@ -301,27 +332,56 @@ (defmethod port-beep ((port motif-port) (sheet t)) (x11:xbell (tk::display-handle (port-display port)) 100)) -(defmethod silica::port-draw-circle* ((port motif-port) - sheet - medium - center-x - center-y - radius - filled) + +(defmethod silica::port-draw-ellipse* ((port motif-port) + sheet + medium + center-x + center-y + radius-1-dx + radius-1-dy + radius-2-dx + radius-2-dy + start-angle + end-angle + filled) (let ((transform (compose-transformations (medium-transformation medium) (sheet-device-transformation sheet)))) (multiple-value-setq (center-x center-y) (devicize-point transform center-x center-y)) - (tk::draw-circle + + + (multiple-value-setq (radius-1-dx radius-1-dy) + (devicize-distance transform radius-1-dx radius-1-dy)) + + + (multiple-value-setq (radius-2-dx radius-2-dy) + (devicize-distance transform radius-2-dx + radius-2-dy)) + + (tk::draw-ellipse (tk::widget-window (sheet-mirror sheet)) (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium)) + (clx-decode-ink (medium-ink medium) medium) + (medium-ink medium) + (medium-line-style medium) + (- center-x + (if (zerop radius-1-dx) + radius-2-dx + radius-1-dx)) + (- center-y + (if (zerop radius-1-dy) + radius-2-dy + radius-1-dy))) center-x center-y - radius + radius-1-dx + radius-1-dy + radius-2-dx + radius-2-dy + start-angle + end-angle filled))) (ff::def-c-type (xpoint-array :in-foreign-space) 2 x11::xpoint) @@ -341,7 +401,9 @@ ((and closed (not filled)) (incf npoints)) (t npoints))))) - (window (tk::widget-window (sheet-mirror sheet)))) + (window (tk::widget-window (sheet-mirror sheet))) + (minx most-positive-fixnum) + (miny most-positive-fixnum)) (do ((ps list-of-x-and-ys (cddr ps)) (i 0 (1+ i)) @@ -351,6 +413,8 @@ (multiple-value-bind (x y) (devicize-point transform (car ps) (cadr ps)) + (minf minx x) + (minf miny y) (setf (xpoint-array-x points i) x (xpoint-array-y points i) y))) @@ -365,7 +429,9 @@ (tk::object-handle (clx-adjust-ink medium (clx-decode-ink (medium-ink medium) medium) (medium-ink medium) - (medium-line-style medium))) + (medium-line-style medium) + minx + miny)) points npoints x11:complex @@ -376,10 +442,62 @@ (tk::object-handle (clx-adjust-ink medium (clx-decode-ink (medium-ink medium) medium) (medium-ink medium) - (medium-line-style medium))) + (medium-line-style medium) + minx + miny)) points npoints x11:coordmodeorigin)))) - - + + +(defmethod clx-decode-ink ((ink rectangular-tile) medium) + (multiple-value-bind (pattern width height) + (decode-rectangular-tile ink) + (clx-decode-pattern pattern medium width height t))) + +(defmethod clx-decode-ink ((ink pattern) medium) + (clx-decode-pattern ink medium)) +(defmethod clx-decode-pattern ((pattern pattern) medium &optional width height tiled-p) + (let ((ink-table (slot-value medium 'ink-table))) + (or (gethash pattern ink-table) + (setf (gethash pattern ink-table) + (multiple-value-bind + (array designs) + (decode-pattern pattern) + (let ((image-data (make-array (array-dimensions array)))) + (dotimes (w (array-dimension array 1)) + (dotimes (h (array-dimension array 0)) + (setf (aref image-data h w) + (clx-decode-color medium + (elt designs (aref array h w)))))) + (let* ((pattern-height (array-dimension array 0)) + (pattern-width (array-dimension array 1)) + (image (make-instance + 'tk::image + :width pattern-width + :height pattern-height + :data image-data + :depth 8 ;; hardwire + )) + (gc + (make-instance 'tk::gcontext + :drawable (tk::display-root-window + (port-display (port + medium))))) + (pixmap + (make-instance 'tk::pixmap + :drawable (tk::display-root-window + (port-display (port + medium))) + + :width pattern-width + :height pattern-height + :depth 8))) + (tk::put-image pixmap gc image :x 0 :y 0) + (setf (tk::gcontext-tile gc) pixmap + (tk::gcontext-fill-style gc) :tiled) + gc))))))) + + + diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index b353144d..2a6d620b 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -1,4 +1,4 @@ -(in-package :xm-silica) +;; -*- 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. @@ -18,6 +18,10 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ + +(in-package :xm-silica) + (defmethod find-port-type ((type (eql ':motif))) 'motif-port) @@ -75,16 +79,14 @@ (let* () (flet ((font->text-style (font family) - (let* ((tokens (disassemble-x-font-name (tk::font-name font))) + (let* ((tokens (disassemble-x-font-name font)) (italic (member (fifth tokens) '("i" "o") :test #'equalp)) (bold (equalp (fourth tokens) "Bold")) (face (if italic (if bold '(:bold :italic) :italic) (if bold :bold :roman))) - (designed-point-size (or (tk::font-property font :POINT_SIZE) - (parse-integer (ninth tokens)))) - (designed-y-resolution (or (tk::font-property font :RESOLUTION_Y) - (parse-integer (nth 10 tokens)))) + (designed-point-size (parse-integer (ninth tokens))) + (designed-y-resolution (parse-integer (nth 10 tokens))) (point-size (float designed-point-size)) (size (/ point-size 10))) (make-text-style family face size)))) @@ -92,17 +94,13 @@ (let ((family (car family-stuff))) (dolist (font-pattern (cdr family-stuff)) (dolist (xfont (tk::list-font-names display font-pattern)) - (let ((xfont (make-instance - 'tk::font - :display display - :name xfont))) (let ((text-style (font->text-style xfont family))) ;; prefer first font satisfying this text style, so ;; don't override if we've already defined one. (unless (silica::text-style-mapping-exists-p display-device *standard-character-set* text-style t) (silica::add-text-style-mapping display-device *standard-character-set* - text-style xfont)))))) + text-style xfont))))) ;; Now build the logical size alist for the family @@ -328,7 +326,7 @@ (sheet-mirror ma)))) (defmethod find-shell-class-and-initargs (port sheet) - (values 'top-level-shell '())) + (values 'top-level-shell nil)) (defmethod enable-mirror (port sheet) (declare (ignore port)) @@ -456,6 +454,23 @@ (silica::text-style-mapping port nil font nil)) + +(defmethod text-style-mapping :around ((device motif-port) + character-set + text-style + etc) + (declare (ignore etc)) + (let ((font (call-next-method))) + (when (or (stringp font) (symbolp font)) + (let* ((font-name (string font))) + (setf font (make-instance 'tk::font + :display (port-display device) + :name font-name)) + (add-text-style-mapping + device character-set (parse-text-style text-style) font))) + font)) + + (defmethod silica::text-style-width ((text-style text-style) medium) (tk::font-width (realize-text-style (port medium) text-style))) diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index ffd536c2..ead8205d 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defforeign 'add_callback diff --git a/tk/convenience.lisp b/tk/convenience.lisp index 7b104ba0..e2edf484 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) ; diff --git a/tk/defsys.lisp b/tk/defsys.lisp index 4f51d92c..9eb4a528 100644 --- a/tk/defsys.lisp +++ b/tk/defsys.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: user -*- +;; +;; -[]- +;; +;; 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$ + (defsys::defsystem :xm-tk (:default-pathname (frob-pathname "tk")) diff --git a/tk/event.lisp b/tk/event.lisp index 124fa95c..2e6eed9d 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defforeign 'app_pending diff --git a/tk/examples.lisp b/tk/examples.lisp index dbf46d37..e16f1022 100644 --- a/tk/examples.lisp +++ b/tk/examples.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) ;;; CLM bitmap code diff --git a/tk/font.lisp b/tk/font.lisp index 9f113bb2..13de4ca9 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defclass font (handle-class) diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp index c8c7103d..56aedb48 100644 --- a/tk/foreign-obj.lisp +++ b/tk/foreign-obj.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defclass handle-class () diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 981663c7..2214315b 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (eval-when (compile load eval) @@ -15,8 +39,8 @@ (arc-mode :int) (tile :pixmap) (stipple :pixmap) - (ts-x :int) - (ts-y :int) + (ts-x-origin :int) + (ts-y-origin :int) (font x-font) (subwindow-mode :int) (exposures :boolean) @@ -29,7 +53,7 @@ (defconstant *gcontext-bit-mask* '(function plane-mask foreground background line-width line-style cap-style join-style fill-style - fill-rule tile stipple ts-x ts-y font subwindow-mode + fill-rule tile stipple ts-x-origin ts-y-origin font subwindow-mode exposures clip-x clip-y clip-mask dash-offset dashes arc-mode))) @@ -126,14 +150,15 @@ (x11:xchangegc (display-handle (object-display gc)) (object-handle gc) - ,(ash 1 (position name *gcontext-bit-mask*)) + ,(ash 1 (or (position name *gcontext-bit-mask*) + (error "Cannot find ~S in gcontext components" name))) gc-values) nv)))) (defmacro define-gc-reader (name decoder &rest args) `(defmethod ,(intern (format nil "~A-~A" 'gcontext name)) (gc) (,decoder - (,(intern (format nil "~A~A" 'xgcvalues- name) :x11) + (,(intern (format nil "~A~A" '_xgc-values- name) :x11) (object-handle gc)) ,@args))) @@ -152,10 +177,10 @@ ;(define-gc-accessor background (encode-pixel decode-pixel)) (defmethod gcontext-foreground ((gc gcontext)) - (decode-pixel (x11:xgcvalues-foreground (object-handle gc)))) + (decode-pixel (x11::_xgc-values-foreground (object-handle gc)))) (defmethod gcontext-background ((gc gcontext)) - (decode-pixel (x11:xgcvalues-background (object-handle gc)))) + (decode-pixel (x11::_xgc-values-background (object-handle gc)))) (defmethod (setf gcontext-foreground) (nv (gc gcontext)) (x11:xsetforeground @@ -177,10 +202,13 @@ (define-gc-accessor tile (encode-pixmap decode-pixmap)) (define-gc-accessor stipple (encode-pixmap decode-pixmap)) +(defun encode-pixmap (x) + (object-handle x)) -(define-gc-accessor ts-x (encode-int16 decode-int16)) -(define-gc-accessor ts-y (encode-int16 decode-int16)) +(define-gc-accessor ts-x-origin (encode-int16 decode-int16)) +(define-gc-accessor ts-y-origin (encode-int16 decode-int16)) + (define-gc-accessor font (encode-font decode-font)) (define-gc-accessor line-style (encode-enum decode-enum) '(:solid :dash :double-dash)) (define-gc-accessor cap-style (encode-enum decode-enum) '(:not-last :butt :round :projecting)) @@ -327,6 +355,8 @@ (defmethod encode-pixel ((x integer)) x) + +(defun decode-pixel (x) x) (defmethod encode-pixel ((x color)) (allocate-color (default-colormap display 0) x)) diff --git a/tk/graphics.lisp b/tk/graphics.lisp index df8ad9c1..82060c95 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defun draw-point (drawable gcontext x y) @@ -27,6 +51,53 @@ y2)) +(defun draw-ellipse (drawable gcontext center-x + center-y + radius-1-dx + radius-1-dy + radius-2-dx + radius-2-dy + start-angle + end-angle + filled) + (multiple-value-bind (x-radius y-radius) + (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) + (values (abs radius-2-dx) (abs radius-1-dy))) + ((and (= radius-2-dx 0) (= radius-1-dy 0)) + (values (abs radius-1-dx) (abs radius-2-dy))) + (t + (let ((s-1 (+ (* radius-1-dx radius-1-dx) + (* radius-1-dy radius-1-dy))) + (s-2 (+ (* radius-2-dx radius-2-dx) + (* radius-2-dy radius-2-dy)))) + (if (= s-1 s-2) + (let ((r (truncate (sqrt s-1)))) + (values r r)) + ;; Degrade to drawing a rectilinear ellipse + (values (truncate (sqrt s-1)) + (truncate (sqrt s-2))))))) + (if filled + (x11:xfillarc + (display-handle (object-display drawable)) + (object-handle drawable) + (object-handle gcontext) + (- center-x x-radius) + (- center-y y-radius) + (* 2 x-radius) + (* 2 y-radius) + 0 + (* 360 64)) + (x11:xdrawarc + (display-handle (object-display drawable)) + (object-handle drawable) + (object-handle gcontext) + (- center-x x-radius) + (- center-y y-radius) + (* 2 x-radius) + (* 2 y-radius) + 0 + (* 360 64))))) + (defstub draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) ) diff --git a/tk/init.lisp b/tk/init.lisp index c4b8d31c..2e12ace8 100644 --- a/tk/init.lisp +++ b/tk/init.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index 7aee1409..84c77942 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) #| diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index ffe7c1ad..140e07d5 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) #| diff --git a/tk/loadit.lisp b/tk/loadit.lisp index 6eb9d47c..04f8e6d4 100644 --- a/tk/loadit.lisp +++ b/tk/loadit.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: user -*- +;; +;; -[]- +;; +;; 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$ + (load "pkg") (load "foreign-obj") (load "load-xm") diff --git a/tk/macros.lisp b/tk/macros.lisp index 17ecf840..fba667dd 100644 --- a/tk/macros.lisp +++ b/tk/macros.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defmacro with-ref-par (bindings &body body) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 223a8a8f..09511905 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (ff:defforeign 'insert_classes :return-type :fixnum) diff --git a/tk/ol-examples.lisp b/tk/ol-examples.lisp index 796d59ff..e441ccd7 100644 --- a/tk/ol-examples.lisp +++ b/tk/ol-examples.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defun example-1 () diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index 5371b089..dddb01c5 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) diff --git a/tk/pkg.lisp b/tk/pkg.lisp index 8239ba3d..46716172 100644 --- a/tk/pkg.lisp +++ b/tk/pkg.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: user -*- +;; +;; -[]- +;; +;; 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$ + (defpackage :tk (:use common-lisp ff) (:export diff --git a/tk/resources.lisp b/tk/resources.lisp index e66fc435..d64bba28 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defmacro define-enumerated-resource (type elements) @@ -23,9 +47,9 @@ (defun make-arglist-for-class (class parent args) (do ((new-args nil) - (resources (append - (class-resources class) - (and parent (class-constraint-resources (class-of parent))))) + (resources-1 (class-resources class)) + (resources-2 (and parent (class-constraint-resources + (class-of parent)))) keyword value) ((null args) @@ -34,7 +58,8 @@ :initial-contents (nreverse new-args))) (setq keyword (pop args) value (pop args)) - (let ((resource (find keyword resources :key #'resource-name))) + (let ((resource (or (find keyword resources-1 :key #'resource-name) + (find keyword resources-2 :key #'resource-name)))) (when resource (push (resource-original-name resource) new-args) (push (convert-resource-out parent (resource-type resource) value) diff --git a/tk/widget.lisp b/tk/widget.lisp index ee1c4b5b..693119f5 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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. +;; +;; $aclHeader$ + (in-package :tk) (defun app-create-shell (&rest args @@ -59,6 +83,13 @@ (manage_child (object-handle child))) +(defforeign 'unmanage_child + :entry-point "_XtUnmanageChild") + +(defun unmanage-child (child) + (unmanage_child (object-handle child))) + + (defforeign 'create_popup_shell :entry-point "_XtCreatePopupShell") diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 052889c6..4647a11a 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) ;;; Pathetic clos interface to Xlib @@ -15,11 +39,29 @@ -(defclass window (display-object handle-class) +(defclass drawable (display-object handle-class) + ()) + +(defclass window (drawable) ()) +(defclass pixmap (drawable) + ()) - +(defforeign 'x_create_pixmap + :entry-point "_XCreatePixmap") + +(defmethod initialize-instance :after ((p pixmap) &key width height + depth drawable) + (setf (slot-value p 'handle) + (x_create_pixmap + (display-handle display) + (object-handle drawable) + width + height + depth)) + (register-address p)) + (defun-c-callable x-error-handler (display (x :unsigned-long)) (error "x-error:~S" (get-error-text (x11:xerrorevent-error-code x)))) @@ -252,3 +294,58 @@ compose-status) (char*-to-string buffer) (aref keysym 0))))) + +(defclass image (handle-class) + ((width :reader image-width :initarg :width) + (height :reader image-height :initarg :height))) + + +(defforeign 'x_create_image + :entry-point "_XCreateImage") + +(defmethod initialize-instance :after ((i image) &key width height data depth) + (let (v) + (ecase depth + (8 + (setq v (excl::malloc (* width height))) + (dotimes (w width) + (dotimes (h height) + (setf (sys::memref-int v (+ (* h width) w) 0 :unsigned-byte) + (aref data h w)))))) + (let* ((bytes-per-line 0) + (bitmap-pad 8) ;;; Why is this 8 - if 0 get signal 8! + (visual (x11:screen-root-visual + (display-default-screen display))) + (format x11:zpixmap) + (offset 0) + (x (x_create_image + (display-handle display) + visual + depth + format + offset + v + width + height + bitmap-pad + bytes-per-line))) + (setf (slot-value i 'handle) x)))) + + +(defforeign 'x_put_image + :entry-point "_XPutImage") + +(defmethod put-image (pixmap gc image &key x y) + (x_put_image + (display-handle display) + (object-handle pixmap) + (object-handle gc) + (object-handle image) + 0 ;; src-x + 0 ;; src-t + 0 ;; dest-x + 0 ;; dest-y + (image-width image) + (image-height image))) + + diff --git a/tk/xm-init.lisp b/tk/xm-init.lisp index 412bf945..bad9bf6c 100644 --- a/tk/xm-init.lisp +++ b/tk/xm-init.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp index 3d6265a0..50002c50 100644 --- a/tk/xm-protocols.lisp +++ b/tk/xm-protocols.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defforeign 'xm_add_protocol_callback diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index c3d22bd5..9bb8b48a 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (defgeneric make-widget (widget &key) diff --git a/tk/xtk.lisp b/tk/xtk.lisp index 245daaa0..c8b49cd2 100644 --- a/tk/xtk.lisp +++ b/tk/xtk.lisp @@ -1,3 +1,27 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; 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 :tk) (def-c-typedef :cardinal :unsigned-int) diff --git a/utils/condpat.lisp b/utils/condpat.lisp index e74bea2d..50169f8b 100644 --- a/utils/condpat.lisp +++ b/utils/condpat.lisp @@ -18,6 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ (in-package :clim-utils) diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp index 01ac0840..71f85ead 100644 --- a/utils/defun-utilities.lisp +++ b/utils/defun-utilities.lisp @@ -18,6 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ (in-package :clim-utils) diff --git a/utils/reader.lisp b/utils/reader.lisp index 92f69822..5c396cea 100644 --- a/utils/reader.lisp +++ b/utils/reader.lisp @@ -18,6 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; +;; $fiHeader$ (in-package :clim-utils) diff --git a/utils/regions.lisp b/utils/regions.lisp index 647a48a2..5b33884c 100644 --- a/utils/regions.lisp +++ b/utils/regions.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: regions.lisp,v 1.1 91/08/30 13:57:50 cer Exp Locker: cer $ +;; $fiHeader: regions.lisp,v 1.1 91/11/25 10:01:45 cer Exp Locker: cer $ (in-package :clim-utils) @@ -873,7 +873,9 @@ ;; not axis-aligned. It's not worth computing anything tighter because ;; the refined highlighting test will be faster than the computation of ;; a tighter box. -(defun elliptical-arc-box (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy + +(defun elliptical-arc-box (center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy theta-1 theta-2 thickness) (let* ((filled (null thickness)) (thickness (or thickness 0)) @@ -888,35 +890,46 @@ (setq theta-1 (mod theta-1 2pi) theta-2 (mod theta-2 2pi)) ;;--- Fix the NYI stuff some year - (let* ((x-radius (cond ((zerop radius-1-dx) radius-2-dx) - ((zerop radius-2-dx) radius-1-dx) - (t (nyi)))) - (y-radius (cond ((zerop radius-1-dy) radius-2-dy) - ((zerop radius-2-dy) radius-1-dy) - (t (nyi)))) - (x1 (+ center-x (* x-radius (cos theta-1)))) - (y1 (+ center-y (* y-radius (sin theta-1)))) - (x2 (+ center-x (* x-radius (cos theta-2)))) - (y2 (+ center-y (* y-radius (sin theta-2)))) - (left (min x1 x2)) - (top (min y1 y2)) - (right (max x1 x2)) - (bottom (max y1 y2))) - (when (angle-between-angles-p pi-single-float theta-1 theta-2) - (minf left (- center-x x-radius))) - (when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2) - (minf top (- center-y y-radius))) - (when (angle-between-angles-p 0 theta-1 theta-2) - (maxf right (+ center-x x-radius))) - (when (angle-between-angles-p pi/2 theta-1 theta-2) - (maxf bottom (+ center-y y-radius))) - (when filled - (minf left center-x) - (minf top center-y) - (maxf right center-x) - (maxf bottom center-y)) - (fix-rectangle (- left lthickness) (- top lthickness) - (+ right rthickness) (+ bottom rthickness))))) + + (multiple-value-bind (x-radius y-radius) + (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) + (values (abs radius-2-dx) (abs radius-1-dy))) + ((and (= radius-2-dx 0) (= radius-1-dy 0)) + (values (abs radius-1-dx) (abs radius-2-dy))) + (t + (let ((s-1 (+ (* radius-1-dx radius-1-dx) + (* radius-1-dy radius-1-dy))) + (s-2 (+ (* radius-2-dx radius-2-dx) + (* radius-2-dy radius-2-dy)))) + (if (= s-1 s-2) + (let ((r (truncate (sqrt s-1)))) + (values r r)) + ;; Degrade to drawing a rectilinear ellipse + (values (truncate (sqrt s-1)) + (truncate (sqrt s-2))))))) + (let* ((x1 (+ center-x (* x-radius (cos theta-1)))) + (y1 (+ center-y (* y-radius (sin theta-1)))) + (x2 (+ center-x (* x-radius (cos theta-2)))) + (y2 (+ center-y (* y-radius (sin theta-2)))) + (left (min x1 x2)) + (top (min y1 y2)) + (right (max x1 x2)) + (bottom (max y1 y2))) + (when (angle-between-angles-p pi-single-float theta-1 theta-2) + (minf left (- center-x x-radius))) + (when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2) + (minf top (- center-y y-radius))) + (when (angle-between-angles-p 0 theta-1 theta-2) + (maxf right (+ center-x x-radius))) + (when (angle-between-angles-p pi/2 theta-1 theta-2) + (maxf bottom (+ center-y y-radius))) + (when filled + (minf left center-x) + (minf top center-y) + (maxf right center-x) + (maxf bottom center-y)) + (fix-rectangle (- left lthickness) (- top lthickness) + (+ right rthickness) (+ bottom rthickness)))))) (defun angle-between-angles-p (theta theta-1 theta-2) (unless (< theta-1 theta-2) -- GitLab