Date: Fri, 8 Dec 95 16:46:15 CST From: "Robert P. Goldman" To: garnet-users@H.GP.CS.CMU.EDU, garnet-bugs@H.GP.CS.CMU.EDU Subject: patch for problem with true color displays I believe that I have successfully fixed the bug in reconnecting true-color displays to Garnet. Here's what goes wrong: As part of reconnecting garnet, garnet tries to determine, by alloc-color-cells, what is the next colormap index available for allocation. On a true-color (or static-color) display, colormap entries CANNOT be allocated by alloc-color-cells, because those display types do not support read-write colormap cells. I have fixed this bug, to the best of my knowledge, by adding a new variable to complement the *is-this-a-color-screen?* variable --- *read-write-colormap-cells-p*. This variable is true when we have a color display and that color display supports the allocation of R/W colormap cells. The files that needed to be changed are three files in OPAL: DEFS.LISP CREATE-INSTANCES.LISP and OPEN-AND-CLOSE.LISP I will mail these three files out in a set of three following email messages. I will also tar the files together and make them available through my home page. I don't offer any guarantees, but I'd be happy to work with anyone who finds that I've done something wrong. By the way, I am far from sure that I have succeeded in completely eliminating the underlying assumption in Garnet that COLOR-DISPLAY === HAS R/W COLORMAP CELLS There's some additional code in create-instances that updates information about free colormap cells. Since TRUE-COLOR displays should never need to allocate new colormap cells, I have preferred to let sleeping dogs lie. Many thanks to Russell Almond for helping me track down enough documentation to make this patch. Best, R ------- Message 2 Date: Fri, 8 Dec 95 17:37:34 CST From: "Robert P. Goldman" To: garnet-users@H.GP.CS.CMU.EDU Subject: revised defs.lisp ;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Opal:Defs.Lisp ;;; ;;; This file contains all the defvars, defconstants, defstructs, etc., ;;; which are used by Opal. This does not contain any defmacros, however. ;;; This file also contains the export list for Opal. ;;; ;;; Change Log: ;;; date who what ;;; ---- --- ---- ;;; 8-Dec-95 goldman Added variable *read-write-colormap-cells-p* ;;; See documentation string thereof. ;;; 12-Sep-95 goldman Changed the way colormap entries are tracked in ;;; from using a fixed-size array to using a hash-table. ;;; Applied a patch from Nick Levine that makes it ;;; possible for garnet to deal with True Color displays. ;;; 25-May-94 amickish Made setf of *function-alist* a GEM method ;;; 17-Dec-93 amickish :x-image ---> :device-image in HALFTONE defstruct ;;; 5-Dec-93 amickish Removed Do-Defs-Initializations (temporary GEM fn) ;;; 30-Sep-93 amickish Supported gray-scale screens in initialize-x11-values ;;; 30-Aug-93 amickish Moved defvar of *cursor-width* to text.lisp ;;; 20-Aug-93 rajan Exported motif-light-xxx and motif-light-xxx-fill ;;; 6-Aug-93 amickish Added opal:Arrow-Pair ;;; 16-Jul-93 amickish Moved Set-Draw-Functions here from basics.lisp ;;; 10-Jun-93 Jim Davis Bound *print-pretty* to NIL while calling princ-to- ;;; string when trying to determine if screen is color. ;;; 10-Jun-93 amickish Set *HP-display-type?* for HP-XOR-Hack ;;; 20-May-93 amickish restored conditional definition of *function-alist* ;;; 6-Apr-93 koz removed defunct with-*-styles ;;; 18-Jan-93 amickish Added char-width, change-cursors, and restore-cursors ;;; to export list ;;; 5-Jan-93 amickish Removed *is-this-a-color-screen-and-is-black-zero* ;;; 15-Dec-92 amickish Unexported opal:type-check and opal:window ;;; 10-Dec-92 amickish *drawable-to-window-mapping* ---> *garnet-windows* ;;; 25-Nov-92 amickish Exported gray-line ;;; 22-Oct-92 koz added zoom-window and fullzoom-window to exports ;;; 11-Jun-92 ecp Altered *twopi* due to bug in CMUCL 16. ;;; 9-Jun-92 amickish Exported white-line ;;; 29-May-92 ecp/ky Determine display number and screen number from ;;; full display name. ;;; 21-Apr-92 ecp Added main-event-loop-process-running-p ;;; 20-Apr-92 Poelman added string-upcase calls when checking color screen ;;; 2-Apr-92 rgm added set-standard-font; moved export of multifont ;;; routines to multifont.lisp ;;; 1-Apr-92 ecp Must undo change of 26-Feb-92 in CMUCL. ;;; 31-Mar-92 ecp It is necessary to have a third case when declaring ;;; *function-alist*, for color screens where white=1, ;;; such as the HP machine. ;;; 31-Mar-92 bam Renamed initialize-virtual-aggregate-bboxes to be ;;; recalculate-virtual-aggregate-bboxes ;;; 20-Mar-92 ecp Moved exports here from virtual-aggregates and multifont. ;;; 10-Mar-92 ecp Gave halftone new filling-style field. ;;; 27-Feb-92 ecp Added deiconify-window. ;;; 26-Feb-92 ecp Must call xlib:open-display a second time when getting ;;; *default-x-colormap*. ;;; 6-Feb-92 ecp Added leaf-objects-in-rectangle, components-in-rectangle, ;;; and obj-in-rectangle. ;;; 31-Jan-92 ecp Eliminated *display-name-to-display-mapping* ;;; 26-Nov-91 ecp Use *copy* instead of *clear* for erasing buffers. ;;; 26-Mar-91 ecp kcl patch ;;; 7-Mar-91 ecp The question of whether the screen is color or ;;; black-and-white is now determined inside ;;; initialize-default-x-values. ;;; 22-Feb-91 amickish New exported motif colors and filling styles. ;;; 21-Feb-91 ecp New exported variables *screen-width* and ;;; *screen-height*, which are the width and height ;;; of the screen. Also iconify-window. ;;; 25-Oct-90 ecp New exported commands opal:raise-window and ;;; opal:lower-window which move window to front or ;;; back of screen. ;;; 11-Sep-90 ecp Get display name in allegro by (sys::getenv "DISPLAY"). ;;; Use (short-site-name) as an #+allegro alternative to ;;; (machine-instance). ;;; 15-Aug-90 ecp Exporting destroy-me. ;;; Moved lots of initialization stuff ;;; into new function initialize-default-x-values. ;;; 8-Aug-90 ecp Use #+(and allegro clx-mit-r4) "" in ;;; *default-x-display-name* ;;; 26-Jun-90 ecp Due to temporary bug in clx, had to ;;; coerce *twopi* to an short-float. ;;; 21-Jun-90 nesmith ;;; Use #+allegro (short-site-name) in ;;; *default-x-display-name* ;;; 19-Jun-90 ecp New functions gv-center-x-is-center-of, ;;; gv-center-y-is-center-of, ;;; gv-right-is-left-of, gv-bottom-is-top-of. ;;; 18-Jun-90 ecp Added *clear* for erasing buffers. ;;; 5-Jun-90 chris Added lispworks. ;;; 14-Mar-90 ecp Move-cursor-* functions added. ;;; 9-Mar-90 ecp Changed *function-alist* again to try ;;; to deal with "xor problem". ;;; Moved lots of defvars here from new-defs. ;;; New variables *white* and *black*. ;;; 13-Feb-90 ecp Implemented color. ;;; 26-Jan-90 bam Added :key-press and :button-press to ;;; *exposure-event-mask* ;;; 13-Dec-89 ecp Changed #+lucid to #-cmu in declaration of ;;; *function-alist* ;;; 14-Jun-89 koz Created. Simply extracted all the def* from all the ;;; Opal files. No modifications were made to them. ;;;--------------------------------------------------------------------------- ;;; Local changes ;;; [1995/09/11:goldman] incorporated Nick Levine's patch to determine ;;; whether we have a color screen. ;;;--------------------------------------------------------------------------- (in-package "OPAL") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;; Export List ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is the export list for *some* of OPAL (eval-when (eval load compile) (export '(bottom right center-x center-y gv-bottom gv-right gv-center-x gv-center-y gv-center-x-is-center-of gv-center-y-is-center-of gv-right-is-left-of gv-bottom-is-top-of top-side left-side bottom-side right-side center set-center bounding-box set-bounding-box set-position set-size draw erase rotate initialize calculate-bounding-box point-in-gob halftone halftone-darker halftone-lighter halftone-image halftone-image-darker halftone-image-lighter read-image write-image add-component remove-component move-component add-components remove-components remove-all-components do-components do-all-components point-to-component point-to-leaf set-aggregate-hit-threshold update destroy destroy-me raise-window lower-window iconify-window deiconify-window zoom-window fullzoom-window ;; Class names aggregate view-object graphical-object line rectangle roundtangle multipoint polyline polygon text bitmap arc oval circle arrowhead multi-text cursor-multi-text line-style default-line-style filling-style default-filling-style font cursor-text graphic-quality font-from-file cursor-font arrow-cursor arrow-cursor-mask arrow-pair hourglass-cursor hourglass-cursor-mask hourglass-pair with-hourglass-cursor with-cursor default-font display-info-display display-info-screen display-info-root-window display-info-line-style-gc display-info-filling-style-gc convert-coordinates get-cursor-index string-width string-height change-cursors restore-cursors char-width move-cursor-down-one-line move-cursor-up-one-line move-cursor-to-beginning-of-line move-cursor-to-end-of-line Get-X-Cut-Buffer Set-X-Cut-Buffer ;; for interactors' use leaf-objects-in-rectangle components-in-rectangle obj-in-rectangle ;; filling and line style constants no-fill black-fill white-fill gray-fill light-gray-fill dark-gray-fill red-fill green-fill blue-fill yellow-fill cyan-fill orange-fill purple-fill motif-gray-fill motif-blue-fill motif-orange-fill motif-green-fill motif-light-gray-fill motif-light-blue-fill motif-light-orange-fill motif-light-green-fill make-filling-style diamond-fill no-line thin-line line-0 line-1 line-2 line-4 line-8 gray-line dotted-line dashed-line red-line green-line blue-line yellow-line cyan-line orange-line purple-line white-line ;; size of screen *screen-width* *screen-height* ;; Colors color white black red green blue cyan yellow orange purple motif-gray motif-blue motif-orange motif-green motif-light-gray motif-light-blue motif-light-orange motif-light-green ;; From Clean-Up.Lisp clean-up change-garnet-display update-all reset-cursor ;; From open-and-close.lisp disconnect-garnet reconnect-garnet ;; From process.lisp launch-main-event-loop-process kill-main-event-loop-process main-event-loop-process-running-p running-main-event-loop-process-elsewhere-p ;; From virtual-aggregates.lisp virtual-aggregate remove-item add-item change-item point-to-rank recalculate-virtual-aggregate-bboxes do-in-clip-rect get-standard-font ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;; DefConstants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant *twopi* (min (* 2 pi) (coerce (* 2 pi) 'short-float))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;; DefParameters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Added :button-press and :key-press so garnet-debug:ident will work. (defparameter *exposure-event-mask* nil) ;;; These two 2x2x2 arrays are used as a correction to a flaw in xlib:draw-arc (defparameter *left-adjustment* (make-array '(2 2 2) :initial-contents '(((0 1) (0 1)) ((0 1) (0 1))))) (defparameter *top-adjustment* (make-array '(2 2 2) :initial-contents '(((0 1) (0 0)) ((0 0) (0 1))))) (defparameter *width-adjustment* (make-array '(2 2 2) :initial-contents '(((0 1) (0 1)) ((0 1) (0 1))))) (defparameter *height-adjustment* (make-array '(2 2 2) :initial-contents '(((0 1) (1 1)) ((1 1) (0 1))))) ;;; Routines used to get name of display, and extract ;;; display number and screen number. ;;; Normally, the name of a display is of the form ;;; "displayname:displaynumber.screennumber" ;;; (defun get-full-display-name () #+cmu (cdr (assoc :DISPLAY lisp::*environment-list*)) #+(or allegro lispworks kcl clisp) (sys::getenv "DISPLAY") #+(and lucid lcl3.0) (lucid-common-lisp:environment-variable "DISPLAY") #+(and lucid (not lcl3.0)) (system:environment-variable "DISPLAY") ) (defun get-display-name (display) (do* ((dlist (coerce display 'list) (cdr dlist)) (c (car dlist) (car dlist)) (namelist nil) ) ((or (eq c nil) (eq c '#\:)) (coerce (reverse namelist) 'string)) (push c namelist))) (defun get-screen-number (display) (let* ((dlist (coerce display 'list)) (numstr (progn (do ((c (pop dlist) (pop dlist))) ((or (eq c nil) (eq c '#\:)))) (do ((c (pop dlist) (pop dlist))) ((or (eq c nil) (eq c '#\.)))) (do ((c (pop dlist) (pop dlist)) (numlist nil) ) ((or (eq c nil) (eq c '#\.)) (coerce (reverse numlist) 'string)) (push c numlist) ) )) (num (if (equal numstr "") 0 (read-from-string numstr))) ) num)) ;;; The :current-root slot of the following schema indicates the current ;;; device. This is used for all calls to Gem which occur in places where ;;; explicit device information is not available. ;;; The :active-devices slot contains the list of all the devices that ;;; have been initialized. ;;; (create-schema 'DEVICE-INFO (:current-root NIL) (:active-devices NIL)) ;;; DZG - this is unused (defvar *default-x-full-display-name*) (defvar *default-x-display-name*) (defvar *default-x-display*) (defvar *default-x-screen-number*) (defvar *default-x-screen*) (defvar *default-x-root*) (defvar *default-x-colormap*) (defvar *screen-width*) (defvar *screen-height*) (defvar *white*) (defvar *black*) (defvar *function-alist*) (defvar *copy*) ;;replaced old *colormap-index-table* in array form with a hash-table ;;[1995/09/12:goldman] ;; Have to figure out what this really is. ;(defvar *colormap-index-table-size* 256) ;(defvar *colormap-index-table* ; (make-array *colormap-index-table-size* :initial-element 0)) (defvar *colormap-index-table* ;;arguments to make-hash-table NOT well thought out! [1995/09/12:goldman] (make-hash-table :size 256)) (defvar *is-this-a-color-screen?* nil) (defvar *read-write-colormap-cells-p* nil "This variable will be t if the screen type is :direct-color or :pseudo-color.") (defvar *HP-display-type?* nil) (defun set-draw-functions () ;; Alist since CLX likes to get the draw function in the form of an ;; integer. We want to specify nice keywords instead of those silly ;; numbers. (gem:set-draw-function-alist (gv DEVICE-INFO :current-root)) (dolist (fn-pair *function-alist*) (setf (get (car fn-pair) :x-draw-function) (cdr fn-pair)))) ;;; This is also called in reconnect-garnet. ;;; (defun initialize-x11-values (full-display-name root-window) (setq *default-x-display-name* (if full-display-name (get-display-name full-display-name) #-(or allegro clisp) (machine-instance) #+clisp "" #+allegro (short-site-name))) (setq *default-x-screen-number* (get-screen-number full-display-name)) ;; Set up all the Opal variables used to identify display, screen, etc. ;; Unfortunately, these are needed by discard-all-pending-events (in ;; process.lisp), which is called by launch-main-event-loop-process. (gem:set-device-variables root-window) ;; This is really dumb, but it's the only way I can think of ;; to find out if the screen is color or not. ; (let* ((*print-pretty* NIL) ; (colormap-string (string-upcase ; (princ-to-string opal::*default-x-colormap*)))) ; (if (or (search "PSEUDO-COLOR" colormap-string) ; (search "DIRECT-COLOR" colormap-string) ; (search "GRAY-SCALE" colormap-string)) ; (setq *is-this-a-color-screen?* t) ; (setq *is-this-a-color-screen?* nil))) ;;incorporated Nick Levine's patch into the code. ;;[1995/09/11:goldman] ;;further patched this to add *read-write-colormap-cells-p* [1995/12/08:goldman] (let ((color-screen-types '(:pseudo-color :direct-color :static-color :true-color)) (screen-type (xlib::visual-info-class (xlib::screen-root-visual-info *default-x-screen*)))) (setq *is-this-a-color-screen?* (if (member screen-type color-screen-types :test #'eq) screen-type nil)) (setq *read-write-colormap-cells-p* (and *is-this-a-color-screen?* (member screen-type '(:direct-color :pseudo-color) :test #'eq)))) (with-constants-disabled (s-value opal::COLOR :color-p *is-this-a-color-screen?*)) (setq *HP-display-type?* (and *is-this-a-color-screen?* (zerop *black*))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;; DefVars ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *halftone-table-size* 17) (defvar *halftone-table* nil) ;;; used to be set to (build-halftone-table) ;;; but now that's a forward reference. So, ;;; now we setq this after defining that fn. (defvar *default-text-extents* (make-list 9 :initial-element 0)) (defvar no-fill nil) (defvar no-line nil) (defvar *garnet-windows* NIL) ;; debugging tools (defvar *event-debug* nil) (defvar *expose-throw-aways* 0) (defvar *opal-window-count* 0) (defvar diamond-fill NIL) ;; set in halftones.lisp ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;; DefStructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This defstruct generates the functions Make-Halftone, Copy-Halftone, ;;; Halftone-Percent, Halftone-Device-Image, Halftone-Filling-Style, and ;;; Halftone-P. (defstruct (HALFTONE (:print-function halftone-print)) (percent 0) (device-image nil) (filling-style nil)) ;;; This defstruct generates the functions Make-Display-Info, Copy-Display-Info, ;;; Display-Info-Display, Display-Info-Screen, Display-Info-Root-Window, ;;; Display-Info-Line-Style-GC, and Display-Info-Filling-Style-GC. (defstruct (DISPLAY-INFO (:print-function display-info-printer)) display screen root-window line-style-gc filling-style-gc) ;;; This defstruct generates the functions Make-Cut-String, Copy-Cut-String, ;;; Cut-String-String, Cut-String-Width, and Cut-String-Left-Bearing. (defstruct CUT-STRING string width left-bearing) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;; DefSetfs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Accessors that do calculation from basic gob properties ;;; The accessors for the bottom and right of the gob, make it easier to ;;; adjust the far side of the gob's bounding box. (defsetf bottom (gob) (value) `(setf (g-value ,gob :top) (1+ (- ,value (g-value ,gob :height))))) (defsetf right (gob) (value) `(setf (g-value ,gob :left) (1+ (- ,value (g-value ,gob :width))))) ;;; The accessors for the sides of the gob adjust both the dimensions, and ;;; position of the gob based on the given value. (defsetf left-side (gob) (value) `(progn (setf (g-value ,gob :width) (- (g-value ,gob :width) (- ,value (g-value ,gob :left)))) (setf (g-value ,gob :left) ,value))) (defsetf right-side (gob) (value) `(setf (g-value ,gob :width) (+ (g-value ,gob :width) (- ,value (right ,gob))))) (defsetf top-side (gob) (value) `(progn (setf (g-value ,gob :height) (- (g-value ,gob :height) (- ,value (g-value ,gob :top)))) (setf (g-value ,gob :top) ,value))) (defsetf bottom-side (gob) (value) `(setf (g-value ,gob :height) (+ (g-value ,gob :height) (- ,value (bottom ,gob))))) ;;; The following allow access and setting to the gobs center ;;; position. (defsetf center-x (gob) (value) `(setf (g-value ,gob :left) (- ,value (truncate (g-value ,gob :width) 2)))) (defsetf center-y (gob) (value) `(setf (g-value ,gob :top) (- ,value (truncate (g-value ,gob :height) 2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ------- Message 3 Date: Fri, 8 Dec 95 17:38:24 CST From: "Robert P. Goldman" To: garnet-users@H.GP.CS.CMU.EDU Subject: revised create-instances ;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Opal:Create-Instances.Lisp ;;; ;;; This file contains all the calls to KR:Create-Instance which are in Opal. ;;; They appear in the order in which they are listed in the overall Opal ;;; hierarchy, which is listed first. Please keep it that way! ;;; NOTE: the first entry of ":update-slots" MUST be :visible (unless the ;;; value is NIL), elsewise the update algorithm will break! ;;; ;;; Change Log: ;;; date who what ;;; ---- --- ---- ;;; 12-Sep-95 goldman Changed the way colormap entries are tracked in ;;; from using a fixed-size array to using a hash-table. ;;; 25-May-94 amickish New :max-char-ascent/descent formulas for fonts ;;; 19-Apr-94 amickish Reset first-time in first-allocatable-colormap-index ;;; 5-Mar-94 amickish Used names for font slot type declarations ;;; 17-Dec-93 amickish Gem'ified :font-from-file formula ;;; 15-Dec-93 amickish :active-devices slot now contains ?-DEVICE objects ;;; 23-Aug-93 amickish Changed default hit-threshold to 0 ;;; 24-May-93 amickish Changed :width and :height formulas of aggregate to ;;; depend on aggregate's own :left and :top ;;; 3-May-93 amickish Added s-value's in :xcolor formula of opal:COLOR; ;;; added :ps-font-name/size to opal::FONT-FROM-FILE ;;; 19-Apr-93 amickish Added formulas to opal::FONT-FROM-FILE; added ;;; opal:CURSOR-FONT ;;; 3-Mar-93 amickish Added :visible type declaration to VIEW-OBJECT ;;; 10-Feb-93 amickish Added :known-as type declaration to VIEW-OBJECT ;;; 13-Jan-93 amickish Added :xfont, :max-char-ascent, :max-char-descent, ;;; :font-height, and :char-width slots to opal:font; ;;; added parameter declarations ;;; 30-Dec-92 amickish Set :standard-p in get-standard-font for save-agg ;;; 3-Jun-92 amickish Added opal:white-line ;;; 7-Apr-92 amickish Made Get-Standard-Font use default values if NIL ;;; parameters were supplied and added error checking. ;;; 2-Apr-92 rgm new multifont ;;; 25-Mar-92 amickish Get-Values ---> G-Value ;;; 26-Feb-92 ecp An opal:color may have a :color-name slot with a ;;; string like "pink". ;;; 21-Jan-92 amickish Made opal:default-font an instance of opal:font, ;;; added constant formula lists. ;;; 6-Aug-91 dzg Added extra error checking in formulas for :width ;;; and height of aggregate. ;;; 6-Aug-91 amickish Added :ps-font-name and :ps-font-size to opal:font ;;; 5-Aug-91 ecp Made opal:default-font be same as opal:font. ;;; 26-Mar-91 ecp Added :components to :local-only-slots slot of ;;; opal:aggregate. ;;; 7-Mar-91 ecp The question of whether the screen is color or ;;; black-and-white is now determined in defs.lisp. ;;; 22-Feb-91 amickish New exported motif colors and filling styles. ;;; 14-Feb-91 ecp Yet more changes to color so that colors are ;;; deallocated when they are not used anymore. ;;; 8-Feb-91 ecp Added :color-p slot to opal:color to tell if ;;; screen is black-and-white or color. ;;; 10-Aug-90 loyall Made :width, :height of aggregate not depend ;;; directly on :top, :left. ;;; 1-Aug-90 dzg New :local-only-slots slot in opal:view-object ;;; 19-Jul-90 ecp Made thickness of line-1 be 1. ;;; 20-Jun-90 ecp Temporarily made thickness of dotted-line be 1, ;;; due to new CLX bug. ;;; 4-Jun-90 ecp Removed inverse relation between :parent and :child ;;; 16-Apr-90 ecp Moved creation of default-font earlier. ;;; 27-Mar-90 ecp In build-pixmap, changed 0 and 1 to *black* ;;; and *white*. ;;; 19-Mar-90 ecp Got rid of Garnet-Font-Pathname. ;;; Changed :tile to :stipple ;;; 1-Mar-90 ecp In build-pixmap, changed the :bitmap-p argument ;;; to xlib:put-image from t to nil. ;;; 13-Feb-90 ecp Implemented color. ;;; 25-Jan-90 ecp Changes to fonts. ;;; 5-Dec-89 ecp Moved create-instance of FONT-FROM-FILE earlier. ;;; ******* SEE OPAL CHANGE.LOG ******** ;;; 15-Jun-89 koz Placed Graphic-Quality hierarchy before View-Object ;;; to resolve forward references (instead of s-value). ;;; This should fix bug that made Cursor-Text not inherit ;;; the right slots at creation time. ;;; 15-Jun-89 koz Converted from kr:formula to kr:o-formula. ;;; 15-Jun-89 koz Extracted all forward references and placed them all ;;; in S-VALUEs at the end of this file, or in other files ;;; if they needed functions not yet defined... ;;; 14-Jun-89 koz Created. Simply extracted all the calls to kr:create- ;;; instance from all the Opal files. No modifications ;;; were made to them. (in-package "OPAL") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; I *hate* to do this, but this function needs to go here so that the ;;; the reference to it below doesn't generate a warning at compile time. Of ;;; course, we *should* be able to just declare it, but no... Bug in compiler! ;;; (defun build-pixmap (a-window image width height bitmap-p) (gem:create-pixmap a-window width height 1 image bitmap-p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;; The Opal Hierarchy ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| opal:GRAPHIC-QUALITY opal:FONT opal:DEFAULT-FONT opal:COLOR opal:WHITE opal:BLACK opal:RED opal:GREEN opal:BLUE opal:YELLOW opal:CYAN opal:ORANGE opal:PURPLE opal:MOTIF-GRAY opal:MOTIF-BLUE opal:MOTIF-ORANGE opal:MOTIF-GREEN opal:LINE-STYLE opal:DEFAULT-LINE-STYLE opal:THIN-LINE opal:LINE-0 opal:LINE-1 opal:LINE-2 opal:LINE-4 opal:LINE-8 opal:DOTTED-LINE opal:DASHED-LINE opal:RED-LINE opal:GREEN-LINE opal:BLUE-LINE opal:YELLOW-LINE opal:ORANGE-LINE opal:CYAN-LINE opal:PURPLE-LINE opal:WHITE-LINE opal:FILLING-STYLE opal:DEFAULT-FILLING-STYLE opal:WHITE-FILL opal:LIGHT-GRAY-FILL opal:GRAY-FILL opal:DARK-GRAY-FILL opal:BLACK-FILL opal:RED-FILL opal:GREEN-FILL opal:BLUE-FILL opal:YELLOW-FILL opal:ORANGE-FILL opal:CYAN-FILL opal:PURPLE-FILL opal:MOTIF-GRAY-FILL opal:MOTIF-BLUE-FILL opal:MOTIF-ORANGE-FILL opal:MOTIF-GREEN-FILL opal:FONT-FROM-FILE opal:VIEW-OBJECT opal:AGGREGATE opal:MULTIFONT-TEXT opal:AGGREGADGET opal:AGGRELIST opal:GRAPHICAL-OBJECT opal:LINE opal:RECTANGLE opal:ROUNDTANGLE opal:ARC opal:OVAL opal:CIRCLE opal:MULTIPOINT opal:POLYLINE opal:ARROWHEAD opal:TEXT opal:CURSOR-TEXT opal:MULTI-TEXT opal:CURSOR-MULTI-TEXT opal:BITMAP opal::WHITE-FILL-BITMAP opal::LIGHT-GRAY-FILL-BITMAP opal::GRAY-FILL-BITMAP opal::DARK-GRAY-FILL-BITMAP opal:ARROW-CURSOR opal:ARROW-CURSOR-MASK opal:PIXMAP opal:VIRTUAL-AGGREGATE opal:WINDOW |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;; Graphic-Quality Hierarchy ;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (create-instance 'opal:GRAPHIC-QUALITY NIL) (define-method :destroy-me opal:graphic-quality (quality) (destroy-schema quality)) (define-method :destroy opal:graphic-quality (quality) (dolist (instance (copy-list (g-local-value quality :is-a-inv))) (destroy instance)) (destroy-me quality)) (create-instance 'opal::FONT-FROM-FILE opal:graphic-quality :declare ((:parameters :font-path :font-name) (:type ((or string cons) :font-name) ((or null string) :font-path)) (:ignored-slots :display-xfont-plist)) (:xfont (o-formula (fff-to-xfont (gvl :font-from-file) (gv DEVICE-INFO :current-root)))) (:max-char-ascent (o-formula (let ((root (gv DEVICE-INFO :current-root))) (if root (gem:max-character-ascent root (gv :self)) 0)))) (:max-char-descent (o-formula (let ((root (gv DEVICE-INFO :current-root))) (if root (gem:max-character-descent root (gv :self)) 0)))) (:font-height (o-formula (+ (gvl :max-char-ascent) (gvl :max-char-descent)))) (:display-xfont-plist NIL) (:font-path NIL) (:font-name "") ;; Can't transport machine-dependent font info, so just use Courier (:ps-font-name "/Courier") (:ps-font-size (o-formula (gvl :font-height)))) (define-method :initialize opal:font-from-file (fff) (s-value fff :font-from-file fff)) (setf (gethash '(:fixed :roman :medium) *font-hash-table*) (create-instance 'opal::default-font-from-file opal:font-from-file (:font-name (o-formula (gem:make-font-name (gv DEVICE-INFO :current-device) '(:fixed :roman :medium)))))) (defun fff-to-xfont (fff root-window) (gem:font-to-internal root-window fff)) (create-instance 'opal:FONT opal:graphic-quality :declare ((:type (font-family :family) (font-face :face) (font-size :size)) (:maybe-constant :family :face :size)) (:ps-font-name (o-formula (ps-font-name (gvl :family) (gvl :face)))) (:ps-font-size (o-formula (ps-font-size (gvl :size)))) (:family :fixed) (:face :roman) (:size :medium) (:xfont (o-formula (fff-to-xfont (gvl :font-from-file) (gv device-info :current-root)))) (:char-width (o-formula (if (eq (gvl :family) :fixed) (gem:text-width (gv device-info :current-root) (gv :self) "X")))) (:max-char-ascent (o-formula (let ((root (gv DEVICE-INFO :current-root))) (if root (gem:max-character-ascent root (gv :self)) 0)))) (:max-char-descent (o-formula (let ((root (gv DEVICE-INFO :current-root))) (if root (gem:max-character-descent root (gv :self)) 0)))) (:font-height (o-formula (+ (gvl :max-char-ascent) (gvl :max-char-descent)))) (:font-from-file (o-formula (let ((key (list (gvl :family) (gvl :face) (gvl :size)))) (or (gethash key *font-hash-table*) (let* ((root-window (gv DEVICE-INFO :current-device)) (font-name (gem:make-font-name root-window key))) (if (gem:font-name-p root-window font-name) (setf (gethash key *font-hash-table*) (create-instance NIL opal:font-from-file (:font-name font-name))) (progn (warn "~A not allowed for :~A slot of font; substituting default-font." (car font-name) (cdr font-name)) opal::default-font-from-file)))))))) (create-instance 'opal:DEFAULT-FONT opal:FONT (:constant T)) (create-instance 'opal::CURSOR-FONT opal:FONT-FROM-FILE (:constant T) (:font-name "cursor")) ;;; Used in multifonts (defvar *Font-Table* (make-array '(3 4 4) :initial-contents '(((nil nil nil nil) (nil nil nil nil) (nil nil nil nil) (nil nil nil nil)) ((nil nil nil nil) (nil nil nil nil) (nil nil nil nil) (nil nil nil nil)) ((nil nil nil nil) (nil nil nil nil) (nil nil nil nil) (nil nil nil nil))))) ;; Fetch a font from the font table corresponding to the attribute parameters. (defun GET-STANDARD-FONT (family face size) " Get-Standard-Font returns a font object. If this function is called multiple times with the same font specification, the same object will be returned, thus avoiding wasted objects. Allowed values: family -- :fixed, :serif, :sans-serif, or NIL (NIL == :fixed) face -- :roman, :italic, :bold, :bold-italic, or NIL (NIL == :roman) size -- :small, :medium, :large, :very-large, or NIL (NIL == :medium)" (let ((family-num (case (or family (setf family :fixed)) (:fixed 0) (:serif 1) (:sans-serif 2) (t (error "Invalid font family -- ~S" family)))) (face-num (case (or face (setf face :roman)) (:roman 0) (:italic 1) (:bold 2) (:bold-italic 3) (t (error "Invalid font face -- ~S" face)))) (size-num (case (or size (setf size :medium)) (:small 0) (:medium 1) (:large 2) (:very-large 3) (t (error "Invalid font size -- ~S" size))))) (or (aref *Font-Table* family-num face-num size-num) (setf (aref *Font-Table* family-num face-num size-num) (create-instance nil opal:font (:constant T) (:standard-p T) (:family family) (:face face) (:size size)))))) (setf (aref *Font-Table* 0 0 1) opal:default-font) (let ((first-time T) (*first-allocatable-colormap-index* 1)) (defun first-allocatable-colormap-index (root-window) (when first-time ;; Find out the first colormap index that you are actually allowed to ;; allocate and deallocate. ;;THIS WON'T WORK ON A TRUE-COLOR SCREEN! [1995/12/08:goldman] (if *read-write-colormap-cells-p* (setq *first-allocatable-colormap-index* (gem:colormap-property root-window :FIRST-ALLOCATABLE-INDEX))) (setf first-time NIL)) *first-allocatable-colormap-index*) (defun reset-first-allocatable-colormap-index (root-window) (setf first-time T) (first-allocatable-colormap-index root-window)) (defun set-first-allocatable-colormap-index (root-window value) (declare (ignore root-window)) (setf *first-allocatable-colormap-index* value))) (create-instance 'opal:COLOR opal:graphic-quality :declare ((:parameters :red :green :blue :color-name) (:type #+(or lucid allegro-V3.1) (number :red :green :blue) #-(or lucid allegro-V3.1) ((real 0 1) :red :green :blue) ((or string atom) :color-name)) (:constant :color-p)) (:red 1.0) (:green 1.0) (:blue 1.0) (:color-p *is-this-a-color-screen?*) ; Set by initialize-x11-values (:xcolor (o-formula (let ((name (gvl :color-name))) (if name (multiple-value-bind (red green blue) (gem:colormap-property (gv device-info :current-root) :LOOKUP-RGB name) ;; The PS module needs the RGB values (s-value (gv :self) :red red) (s-value (gv :self) :green green) (s-value (gv :self) :blue blue) name) (gem:colormap-property (gv device-info :current-root) :MAKE-COLOR (gvl :red) (gvl :green) (gvl :blue)))))) (:colormap-index (o-formula (let* ((root-window (gv device-info :current-root)) (old-index (g-cached-value (gv :self) :colormap-index)) (new-index (gem:colormap-property root-window :ALLOC-COLOR (gvl :xcolor)))) ;;changed the following [1995/12/08:goldman] (when *read-write-colormap-cells-p* (if (and old-index (>= old-index (first-allocatable-colormap-index root-window)) (zerop (decf (gethash old-index *colormap-index-table*))) ; (zerop (decf (aref *colormap-index-table* old-index))) ) (gem:colormap-property root-window :FREE-COLORS (list old-index))) (incf (gethash new-index *colormap-index-table* 0)) ; (incf (aref *colormap-index-table* new-index)) ) new-index)))) (define-method :destroy-me opal:color (hue) (if *is-this-a-color-screen?* (let ((index (g-cached-value hue :colormap-index))) (dolist (device (g-value DEVICE-INFO :active-devices)) (let ((root-window (g-value device :root-window))) (if (and index ;;replaced the old array with a hash-table (zerop (decf (gethash old-index *colormap-index-table*))) ; (zerop (decf (aref *colormap-index-table* index))) (>= index (first-allocatable-colormap-index root-window))) (gem:colormap-property root-window :FREE-COLORS (list index))))))) (destroy-schema hue)) (create-instance 'opal:RED opal:color (:red 1.0) (:green 0.0) (:blue 0.0)) (create-instance 'opal:GREEN opal:color (:red 0.0) (:green 1.0) (:blue 0.0)) (create-instance 'opal:BLUE opal:color (:red 0.0) (:green 0.0) (:blue 1.0)) (create-instance 'opal:YELLOW opal:color (:red 1.0) (:green 1.0) (:blue 0.0)) (create-instance 'opal:CYAN opal:color (:red 0.0) (:green 1.0) (:blue 1.0)) (create-instance 'opal:PURPLE opal:color (:red 1.0) (:green 0.0) (:blue 1.0)) (create-instance 'opal:ORANGE opal:color (:red 1.0) (:green 0.65) (:blue 0.0)) (create-instance 'opal:WHITE opal:color (:red 1.0) (:green 1.0) (:blue 1.0)) (create-instance 'opal:BLACK opal:color (:red 0.0) (:green 0.0) (:blue 0.0)) (create-instance 'opal:LINE-STYLE opal:graphic-quality :declare ((:type (integer :line-thickness) (keyword :line-style :cap-style :join-style) ((is-a-p opal:color) :foreground-color :background-color)) (:maybe-constant :line-thickness :line-style :cap-style :join-style :dash-pattern :foreground-color :background-color :stipple)) (:line-thickness 0) (:line-style :solid) ;; or :dash or :double-dash (:cap-style :butt) ;; or :not-last, :round or :projecting (:join-style :miter) ;; or :round or :bevel (:dash-pattern nil) (:foreground-color opal::black) (:background-color opal::white) (:stipple nil)) (create-instance 'opal:DEFAULT-LINE-STYLE opal:line-style (:constant T)) (create-instance 'opal::LINE-0 opal:line-style (:constant T)) (defvar opal::THIN-LINE opal::LINE-0) (create-instance 'opal::LINE-1 opal:line-style (:constant T) (:line-thickness 1)) (create-instance 'opal::LINE-2 opal:line-style (:constant T) (:line-thickness 2)) (create-instance 'opal::LINE-4 opal:line-style (:constant T) (:line-thickness 4)) (create-instance 'opal::LINE-8 opal:line-style (:constant T) (:line-thickness 8)) (create-instance 'opal:RED-LINE opal:line-style (:constant T) (:foreground-color opal:red)) (create-instance 'opal:GREEN-LINE opal:line-style (:constant T) (:foreground-color opal:green)) (create-instance 'opal:BLUE-LINE opal:line-style (:constant T) (:foreground-color opal:blue)) (create-instance 'opal:CYAN-LINE opal:line-style (:constant T) (:foreground-color opal:cyan)) (create-instance 'opal:YELLOW-LINE opal:line-style (:constant T) (:foreground-color opal:yellow)) (create-instance 'opal:ORANGE-LINE opal:line-style (:constant T) (:foreground-color opal:orange)) (create-instance 'opal:PURPLE-LINE opal:line-style (:constant T) (:foreground-color opal:purple)) (create-instance 'opal:WHITE-LINE opal:line-style (:constant T) (:foreground-color opal:white)) (create-instance 'opal::DOTTED-LINE opal:line-style (:constant T) (:line-style :dash) (:line-thickness 1) (:dash-pattern '(1 1))) (create-instance 'opal::DASHED-LINE opal:line-style (:constant T) (:line-style :dash) (:dash-pattern '(4 4))) (create-instance 'opal:FILLING-STYLE opal:graphic-quality :declare ((:parameters :foreground-color :background-color :fill-style :fill-rule :stipple) (:type (fill-style :fill-style) ((member :even-odd :winding) :fill-rule) ((is-a-p opal:color) :foreground-color :background-color))) (:fill-style :solid) ;; or :opaque-stippled or :stippled (:fill-rule :even-odd) ;; or :winding (:foreground-color opal::black) (:background-color opal::white) (:stipple nil)) (create-instance 'opal:DEFAULT-FILLING-STYLE opal:filling-style) ;;;; For the *-FILL schemas, please see the end of this file (to avoid ;;;; forward references, they had to be put there).... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;; View-Object Hierarchy ;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (create-instance 'opal:VIEW-OBJECT NIL :declare ((:type (integer :left :top) ((integer 0) :width :height :hit-threshold) (known-as-type :known-as) (kr-boolean :visible)) (:update-slots :visible :fast-redraw-p) (:local-only-slots (:window nil) (:parent nil)) (:sorted-slots :is-a :left :top :width :height :visible :line-style :filling-style :draw-function :components :parent) (:ignored-slots :depended-slots :update-slots :update-slots-values) ) (:left 0) (:top 0) (:width 0) (:height 0) (:hit-threshold 0) (:visible (o-formula (let ((parent (gvl :parent))) (or (null parent) (gv parent :visible))) t)) ;; The following are the controls for the schema printer (:limit-values '((:is-a-inv 5))) (:global-limit-values 5)) ;;; Aggregates allow for a group of graphical-objects to be associated ;;; together to form a new, more complex object. ;;; ;;; An implementation detail: ;;; The children of a gob are stored in a list from bottom most to top ;;; most, since we want to redraw fastest and redraws occur from bottom to ;;; top. (create-instance 'opal:AGGREGATE opal:view-object :declare (:type (list :components)) (:components) (:update-slots NIL) ;; New update does not use AGGREGATE'S visible! (:left (o-formula (let ((min-x 999999)) (dolist (child (gv-local (gv :self) :components)) (when (gv child :visible) (setf min-x (min min-x (gv child :left))))) (if (= min-x 999999) 0 min-x)) 0)) (:top (o-formula (let ((min-y 999999)) (dolist (child (gv-local (gv :self) :components)) (when (gv child :visible) (setf min-y (min min-y (gv child :top))))) (if (= min-y 999999) 0 min-y)) 0)) (:width (o-formula (let ((max-x -999999) (min-x (gvl :left))) (dolist (child (gv-local (gv :self) :components)) (when (gv child :visible) (setf max-x (max max-x (+ (or (gv child :left) 0) (or (gv child :width) 0)))))) (max 0 (- max-x min-x))))) (:height (o-formula (let ((max-y -999999) (min-y (gvl :top))) (dolist (child (gv-local (gv :self) :components)) (when (gv child :visible) (setf max-y (max max-y (+ (or (gv child :top) 0) (or (gv child :height) 0)))))) (max 0 (- max-y min-y))))) (:visible (o-formula (let ((parent (gvl :parent))) (or (null parent) (gv parent :visible))) t)) #| TOA OMITTED ;; The TOA is the Topmost-Overlapping-Aggregate. This slot will hopefully ;; improve the performance of the update algorithm. The formula given here ;; is only for AGGREGATEs. A different one appears within Graphical-Object. (:toa (o-formula (let ((parent (gvl :parent))) (or (and parent (gv parent :toa)) (if (gvl :overlapping) kr::*schema-self*))))) |# ) ;;; Class Graphical-object (create-instance 'opal:GRAPHICAL-OBJECT opal:view-object :declare ((:type ((or (is-a-p opal:line-style) null) :line-style) ((or (is-a-p opal:filling-style) null) :filling-style) ((member :copy :xor :no-op :or :clear :set :copy-inverted :invert :and :equiv :nand :nor :and-inverted :and-reverse :or-inverted :or-reverse) :draw-function)) (:update-slots :visible :fast-redraw-p :line-style :filling-style :draw-function)) (:top 0) (:left 0) (:width 20) (:height 20) (:draw-function :copy) (:line-style opal:default-line-style) (:filling-style nil) (:select-outline-only nil) #| OMITTING TOA ;; The TOA is the Topmost-Overlapping-Aggregate. This slot will hopefully ;; improve the performance of the update algorithm. The formula given here ;; is for NON-AGGREGATE objects. A different one appears within Aggregates. (:toa (o-formula (let ((parent (gvl :parent))) (and parent (gv parent :toa))))) |# ) ------- Message 4 Date: Fri, 8 Dec 95 17:39:08 CST From: "Robert P. Goldman" To: garnet-users@H.GP.CS.CMU.EDU Subject: revised open-and-close.lisp ;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Close all connections to the X server by saying: ;;; (opal:Disconnect-Garnet) ;;; ;;; While the connection to the X server is closed, you may ;;; save a core image of Garnet. To save a core image: ;;; In CMU Common Lisp say (ext:save-lisp filename) ;;; In Allegro Lisp say (excl:dumplisp) ;;; In Lucid Lisp the command is (disksave filename) ;;; ;;; Reopen all connections to the X server by saying: ;;; (opal:Reconnect-Garnet) ;;; #| CHANGE LOG: 12-Sep-95 goldman Had to change the way reconnection is done to reflect the fact that *colormap-index-table* is now a hash table instead of an array. 17-Apr-94 amickish Restored s-value of :lineage to NIL when disconnect; Destroyed colormap slots after all. 25-Mar-94 amickish Eliminated redefinition warnings when reconnecting 15-Dec-93 amickish Do not maintain :display of opal::window; maintain :active-devices of DEVICE-INFO when destroy *root-window* 18-Nov-93 amickish Destroyed X-DEVICE and *root-window* 24-May-93 koz Converted kr::set-slot-accessor calls to use new KR 2.3 format (one more argument) 19-Apr-93 amickish Destroyed font slots in opal:font-from-files 24-Feb-93 amickish moved *auxilliary-reconnect-routines* to new-defs 02-Feb-93 DZG In disconnect-garnet, call kr::set-slot-accessor on the font objects instead of destroy-slot. 01-Feb-93 amickish all-the-instances ---> do-all-instances 13-Jan-93 amickish Now sever X connections to fonts rather than texts 10-Dec-92 amickish *drawable-to-window-mapping* ---> *garnet-windows* 21-Sep-92 amickish No longer necessary to call notice-items-changed on menubars, due to reimplementation of :submenu-window-list in MENUBAR gadget. 22-Jun-92 ECP It is necessary to call notice-items-changed on menubars during the execution of reconnect-garnet. 19-Jun-92 ECP In reconnect-garnet, turn off asynchronous error reports. 29-May-92 ECP/KY Determine display number and screen number from full display name, by calling initialize-x11-values. If you call disconnect-garnet when already disconnected, or reconnect-garnet when already reconnected, exit. 25-May-92 ECP Check that elements of *all-windows* and *all-windows-which-have-been-closed* have not been destroyed. 6-May-92 ECP Only call main-event-loop-process in reconnect-garnet if it had been halted in disconnect-garnet. 16-Apr-92 ECP Call launch-main-event-loop-process at end of reconnect-garnet. 30-Mar-92 amickish Changed funcalls of :update method to update call; Changed the way *all-the-windows* is computed in Disconnect-Garnet. 25-Mar-92 amickish Get-Values ---> G-Value 23-Mar-92 ECP In reconnect-windows, must update all the windows, not just the visible ones. 20-Mar-92 ECP Moved exports to defs.lisp. Use process routines. 11-Mar-92 ECP Added references to kr::*constants-disabled* When reinitializing colors, just call g-value, not s-value. 17-Feb-92 ECP Added *auxilliary-reconnect-routines* 31-Jan-92 ECP Eliminated *display-name-to-display-mapping*. 24-Jan-92 ECP reinitialized text objects in reconnect-garnet. 26-Mar-91 ECP kcl patch 24-Mar-91 ECP Fixed bug involving reconnect to a color screen. 7-Mar-91 ECP The question of whether the screen is color or black-and-white is now determined inside initialize-default-x-values in defs.lisp. 14-Feb-91 ECP More changes to color for connect and disconnect 8-Feb-91 ECP Added :color-p slot to opal:color to tell if screen is black-and-white or color. 11-Sep-90 ECP Get display name in allegro by (sys::getenv "DISPLAY") Use (short-site-name) as an #+allegro alternative to (machine-instance) 15-Aug-90 ECP Yet more debugging. Disconnect-garnet must ; set windows :lineage slot to NIL. Reconnect-garnet has an optional argument. Call to initialize-default-x-values. 14-Aug-90 ECP In reconnect-garnet, just explicitly update top level windows. 10-Aug-90 ECP In reconnect-garnet, recompute display name. 21-Mar-90 ECP Lots of debugging, as well as the above comments. 9-Mar-90 ECP Released locally |# (in-package "OPAL") (defvar *all-the-windows* nil) (defvar *all-windows-which-have-been-closed* nil) (defvar *garnet-has-been-disconnected* nil) #-cmu (defvar *main-event-loop-process-was-halted* nil) (defun do-all-instances (obj a-function &key (self NIL)) (dolist (inst (g-value obj :is-a-inv)) (do-all-instances inst a-function :self NIL) (funcall a-function inst)) (if self (funcall a-function obj))) (defun Destroy-Font-Slots (fnt) (if (kr:g-cached-value fnt :xfont) (gem:delete-font (g-value device-info :current-root) fnt)) ;;; The calls to kr::set-slot-accessor are conceptually the same ;;; as calls to destroy-slot. Destroying all these local slots will case ;;; formulas to be re-inherited and re-evaluated upon reconnection. ;;; ;;; amickish 11/18/93 - Commented out because font formulas now depend ;;; on the DEVICE-INFO schema, and you can make its slots constant if you ;;; want the formulas to become constant. #+comment (progn (kr::set-slot-accessor fnt :xfont kr::*NO-VALUE* 0 NIL) (kr::set-slot-accessor fnt :char-width kr::*NO-VALUE* 0 NIL) (kr::set-slot-accessor fnt :max-char-ascent kr::*NO-VALUE* 0 NIL) (kr::set-slot-accessor fnt :max-char-descent kr::*NO-VALUE* 0 NIL) (kr::set-slot-accessor fnt :font-height kr::*NO-VALUE* 0 NIL) (if (is-a-p fnt opal:font) (kr::set-slot-accessor fnt :font-from-file kr::*NO-VALUE* 0 NIL))) ) (defun Destroy-Color-Slots (col) ;;; Formulas will be re-inherited and re-evaluated upon reconnection ;;; (progn (kr::set-slot-accessor col :xcolor kr::*NO-VALUE* 0 NIL) (kr::set-slot-accessor col :colormap-index kr::*NO-VALUE* 0 NIL))) (defun Disconnect-Garnet () (when *garnet-has-been-disconnected* (return-from disconnect-garnet)) #-cmu (when (opal:main-event-loop-process-running-p) (setq *main-event-loop-process-was-halted* t) (opal:kill-main-event-loop-process)) #+cmu (ext:disable-clx-event-handling opal::*default-x-display*) (setq *all-the-windows* (copy-list *garnet-windows*)) (setq *all-windows-which-have-been-closed* nil) ;;; Make all the windows invisible. (dolist (w *all-the-windows*) (when (and (kr:g-value w :visible) (kr:g-value w :drawable)) (push w *all-windows-which-have-been-closed*) (kr:s-value w :visible nil) (update w))) ; generalized update ;;; Remove all connections to X from the font objects, and from update- ;;; slots array of text objects (opal::do-all-instances opal:font #'Destroy-Font-Slots) (opal::do-all-instances opal:font-from-file #'Destroy-Font-Slots) (opal::do-all-instances opal:color #'Destroy-Color-Slots) (do-all-instances opal:font-from-file #'(lambda (fnt) (kr:s-value fnt :display-xfont-plist nil)) :self T) (do-all-instances opal:text #'(lambda (txt) (if (kr:g-cached-value txt :update-slots-values) (setf (aref (kr:g-cached-value txt :update-slots-values) opal::*text-xfont*) :closed)))) ;;; Remove all connections to X from the window objects. (setf *garnet-windows* NIL) (dolist (w *all-the-windows*) (kr:s-value w :cursor-pairs nil) (kr:s-value w :drawable nil) (kr:s-value w :lineage nil) (kr:s-value w :already-initialized-border-widths nil) (kr:s-value w :event-mask nil) (when (kr:g-cached-value w :display-info) (kr:s-value w :display-info nil))) ;;; Clear all colors. ; (dotimes (n *colormap-index-table-size*) ; (setf (aref *colormap-index-table* n) 0)) ;;we can do this simpler thing because we use a default value of zero ;;for the table entries [1995/09/12:goldman] (setf *colormap-index-table* (make-hash-table :size 256)) (setq *garnet-has-been-disconnected* T)) (defun Reconnect-Garnet (&optional display-name device-type) (unless *garnet-has-been-disconnected* (return-from reconnect-garnet)) (let ((current-device (g-value DEVICE-INFO :current-device)) root-window) (unless device-type (setf device-type (g-value current-device :device-type))) (s-value DEVICE-INFO :active-devices (delete current-device (g-value DEVICE-INFO :active-devices))) (destroy-schema (g-value current-device :root-window)) (destroy-schema current-device) ;; Binding this variable prevents warings when gem::*root-window* and ;; gem::x-device are redefined as the image is restarted. (let ( #+allegro (excl:*redefinition-warnings* NIL) #+apple (ccl:*warn-if-redefine* NIL)) (gem:init-device device-type display-name)) (setf root-window (g-value device-info :current-root)) ;; Should be called in X-Init-Device? #-apple (opal::set-draw-functions) ; defined in defs.lisp ;;the following block of code was erroroneous, because you can't call ;;alloc-color-cells on a :true-color or :static-color screen... ;;conditionalized it. [1995/12/08:goldman] (when *read-write-colormap-cells-p* (let ((indices (gem:colormap-property root-window :ALLOC-COLOR-CELLS))) (reset-first-allocatable-colormap-index root-window) (set-first-allocatable-colormap-index root-window (car indices)) (gem:colormap-property root-window :FREE-COLORS indices))) ;; Re-initialize fonts (with-constants-disabled (do-all-instances opal:text #'(lambda (txt) (let ((vals (g-cached-value txt :update-slots-values))) (if (and vals (eq (aref vals opal::*text-xfont*) :closed)) (setf (aref vals opal::*text-xfont*) (s-value txt :xfont (g-value txt :font :xfont)))))))) (dolist (f *auxilliary-reconnect-routines*) (funcall f)) (dolist (w *all-windows-which-have-been-closed*) (unless (already-been-destroyed w) (kr:s-value w :visible t))) (dolist (w *all-the-windows*) (unless (or (already-been-destroyed w) (kr:g-value w :parent)) (update w T))) (setf *garnet-windows* *all-the-windows*) #+cmu (ext:enable-clx-event-handling opal::*default-x-display* #'inter::default-event-handler) #-cmu (when *main-event-loop-process-was-halted* (opal:launch-main-event-loop-process)) (gem:set-window-property root-window :REPORT-ASYNCHRONOUS-ERRORS NIL) (setq *garnet-has-been-disconnected* nil) t))