From c7695f15d9076a04fc482f908d82b951f0fc67c8 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Fri, 31 Jan 1992 14:28:15 +0000 Subject: [PATCH] Initial revision --- clim/coordinate-sorted-set.lisp | 240 +++ clim/genera-activities.lisp | 94 + clim/item-list-manager.lisp | 96 + clim/prefill.lisp | 1543 +++++++++++++++ clim/text-style.lisp | 659 +++++++ demo/browser.lisp | 1383 +++++++++++++ misc/pixmaps.lisp | 425 ++++ pre-silica/cloe-applications.lisp | 24 + pre-silica/cloe-events.lisp | 291 +++ pre-silica/cloe-implementation.lisp | 1035 ++++++++++ pre-silica/clx-implementation.lisp | 1586 +++++++++++++++ pre-silica/default-application.lisp | 204 ++ pre-silica/define-application.lisp | 1287 +++++++++++++ pre-silica/defs-graphics-generics.lisp | 504 +++++ pre-silica/drawing-state-mixin.lisp | 165 ++ pre-silica/genera-implementation.lisp | 1873 ++++++++++++++++++ pre-silica/graphics-generics.lisp | 387 ++++ pre-silica/graphics-internals.lisp | 427 ++++ pre-silica/laserwriter-metrics.lisp | 2145 +++++++++++++++++++++ pre-silica/postscript-implementation.lisp | 1211 ++++++++++++ pre-silica/protocol-intermediaries.lisp | 98 + pre-silica/vertical-string.lisp | 45 + pre-silica/wheader.lisp | 1634 ++++++++++++++++ pre-silica/window-protocol.lisp | 500 +++++ pre-silica/windows.lisp | 1334 +++++++++++++ utils/ccl-streams.lisp | 16 + utils/cl-stream-classes.lisp | 77 + utils/cl-stream-functions.lisp | 197 ++ utils/clim-macros.lisp | 123 ++ utils/clim-streams.lisp | 24 + utils/coral-char-bits.lisp | 44 + utils/genera-streams.lisp | 116 ++ utils/lisp-package-fixups.lisp | 69 + utils/minima-stream-classes.lisp | 39 + utils/processes.lisp | 259 +++ 35 files changed, 20154 insertions(+) create mode 100644 clim/coordinate-sorted-set.lisp create mode 100644 clim/genera-activities.lisp create mode 100644 clim/item-list-manager.lisp create mode 100644 clim/prefill.lisp create mode 100644 clim/text-style.lisp create mode 100644 demo/browser.lisp create mode 100644 misc/pixmaps.lisp create mode 100644 pre-silica/cloe-applications.lisp create mode 100644 pre-silica/cloe-events.lisp create mode 100644 pre-silica/cloe-implementation.lisp create mode 100644 pre-silica/clx-implementation.lisp create mode 100644 pre-silica/default-application.lisp create mode 100644 pre-silica/define-application.lisp create mode 100644 pre-silica/defs-graphics-generics.lisp create mode 100644 pre-silica/drawing-state-mixin.lisp create mode 100644 pre-silica/genera-implementation.lisp create mode 100644 pre-silica/graphics-generics.lisp create mode 100644 pre-silica/graphics-internals.lisp create mode 100644 pre-silica/laserwriter-metrics.lisp create mode 100644 pre-silica/postscript-implementation.lisp create mode 100644 pre-silica/protocol-intermediaries.lisp create mode 100644 pre-silica/vertical-string.lisp create mode 100644 pre-silica/wheader.lisp create mode 100644 pre-silica/window-protocol.lisp create mode 100644 pre-silica/windows.lisp create mode 100644 utils/ccl-streams.lisp create mode 100644 utils/cl-stream-classes.lisp create mode 100644 utils/cl-stream-functions.lisp create mode 100644 utils/clim-macros.lisp create mode 100644 utils/clim-streams.lisp create mode 100644 utils/coral-char-bits.lisp create mode 100644 utils/genera-streams.lisp create mode 100644 utils/lisp-package-fixups.lisp create mode 100644 utils/minima-stream-classes.lisp create mode 100644 utils/processes.lisp diff --git a/clim/coordinate-sorted-set.lisp b/clim/coordinate-sorted-set.lisp new file mode 100644 index 00000000..1396cf43 --- /dev/null +++ b/clim/coordinate-sorted-set.lisp @@ -0,0 +1,240 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: coordinate-sorted-set.lisp,v 1.4 91/03/26 12:47:48 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." + +;;; The output record generics: +;;; output-record-children: (record) +;;; add-output-record: (child record) +;;; delete-output-record: (child record) +;;; clear-output-record: (record) +;;; replay-output-record: (record stream) +;;; recompute-extent: (record) +;;; recompute-extent-for-new-child: (there's a default): (record child) +;;; recompute-extent-for-changed-child: (record child) +;;; map-over-output-records-overlapping-region: +;;; (function record region +;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) +;;; map-over-output-records-containing-point*: +;;; (function record x y +;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) + +(defclass standard-tree-output-record + (output-record-mixin output-record-element-mixin output-record) + ((coordinate-sorted-set) ;a simple vector, by gawd + (fill-pointer :initform 0) + (tallest-box-height :initform 0))) + +(defmethod initialize-instance :after ((record standard-tree-output-record) + &key (size 200)) + (with-slots (coordinate-sorted-set) record + (setf coordinate-sorted-set (make-array size)))) + + +;; A top-level coordinate sorted set, used for CLIM windows by default +(defclass standard-tree-output-history + (stream-output-history-mixin standard-tree-output-record) + ()) + + +;;; For debugging. +(defmethod output-record-children ((record standard-tree-output-record)) + (with-slots (coordinate-sorted-set fill-pointer) record + (let ((result (make-list fill-pointer))) + (replace result coordinate-sorted-set :end1 fill-pointer :end2 fill-pointer) + result))) + +(defmethod output-record-element ((record standard-tree-output-record) index) + (with-slots (coordinate-sorted-set) record + (svref coordinate-sorted-set index))) + +(defmethod output-record-count ((record standard-tree-output-record)) + (slot-value record 'fill-pointer)) + +(defmethod clear-output-record ((record standard-tree-output-record)) + (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record + (setf tallest-box-height 0) + ;; Release pointers to objects + (fill coordinate-sorted-set nil :start 0 :end fill-pointer) + (setf fill-pointer 0))) + +(defmethod add-output-record (child (record standard-tree-output-record)) + (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record + (let ((vector coordinate-sorted-set) + (fp fill-pointer)) + (declare (type simple-vector vector) #+Genera (sys:array-register vector)) + (declare (fixnum fp)) + (maxf tallest-box-height (bounding-rectangle-height child)) + (with-bounding-rectangle* (left top right bottom) child + (declare (ignore left top)) + ;; Quick check for doing output at the bottom of the window + (if (or (zerop fp) + (let ((other-child (svref vector (1- fp)))) + (when (eq other-child child) + (return-from add-output-record nil)) + (with-bounding-rectangle* (other-left other-top other-right other-bottom) + other-child + (declare (ignore other-left other-top)) + (or (> bottom other-bottom) + (and (= bottom other-bottom) + (>= right other-right)))))) + (multiple-value-setq (coordinate-sorted-set fill-pointer) + (simple-vector-push-extend child vector fp 200)) + (let ((index (coordinate-sorted-set-index-for-position + vector right bottom 0 fp))) + (declare (fixnum index)) + ;; Make sure that the new child comes after any child it overlaps + ;; so that replaying happens in the right order. + (loop + (if (and (< index fp) + (region-intersects-region-p child (svref vector index))) + (incf index) + (return))) + (multiple-value-setq (coordinate-sorted-set fill-pointer) + (simple-vector-insert-element child index vector fp 200)))))))) + +(defmethod delete-output-record + (child (record standard-tree-output-record) &optional (errorp t)) + (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record + (let ((index (coordinate-sorted-set-position child coordinate-sorted-set fill-pointer))) + (cond (index + (let ((new-fp (the fixnum (1- fill-pointer))) + (vector coordinate-sorted-set)) + (declare (type simple-vector vector) (fixnum new-fp) + #+Genera (sys:array-register vector)) + (unless (= (the fixnum index) new-fp) + ;; Shift the whole vector downward + (do ((i (the fixnum index) (1+ i))) + ((= i new-fp)) + (declare (fixnum i) (optimize (speed 3) (safety 0))) + (setf (svref vector i) (svref vector (1+ i))))) + (setf fill-pointer new-fp) + t)) + (errorp + (error "The output record ~S was not found in ~S" child record)))))) + +(defmethod map-over-output-records-overlapping-region + (function (record standard-tree-output-record) region + &optional (x-offset 0) (y-offset 0) &rest continuation-args) + (declare (dynamic-extent function continuation-args)) + (declare (type coordinate x-offset y-offset)) + (declare (optimize (safety 0))) + (let ((vector (slot-value record 'coordinate-sorted-set)) + (length (slot-value record 'fill-pointer))) + (declare (type simple-vector vector) (fixnum length) + #+Genera (sys:array-register vector)) + (if (or (null region) (eql region +everywhere+)) + (dovector ((child index) vector :start 0 :end length :simple-p t) + (apply function child continuation-args)) + (with-bounding-rectangle* (left1 top1 right1 bottom1) region + (translate-fixnum-positions x-offset y-offset left1 top1 right1 bottom1) + (let ((start (coordinate-sorted-set-index-for-position vector 0 top1 0 length)) + (limit (+ bottom1 (slot-value record 'tallest-box-height)))) + (declare (fixnum start limit)) + ;; Subtract out the record offset from the region, to make comparison fair + (multiple-value-bind (xoff yoff) + (output-record-position* record) + (translate-fixnum-positions (- xoff) (- yoff) left1 top1 right1 bottom1)) + (do ((index start (the fixnum (1+ (the fixnum index))))) + ((= (the fixnum index) length)) + (declare (fixnum index)) + (let ((child (svref vector index))) + (with-bounding-rectangle* (left2 top2 right2 bottom2) child + (when (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 + left2 top2 right2 bottom2) + (apply function child continuation-args)) + (when (> bottom2 limit) + (return nil)))))))))) + +(defmethod map-over-output-records-containing-point* + (function (record standard-tree-output-record) x y + &optional (x-offset 0) (y-offset 0) &rest continuation-args) + (declare (dynamic-extent function continuation-args)) + (declare (type coordinate x-offset y-offset)) + (declare (optimize (safety 0))) + (translate-fixnum-positions x-offset y-offset x y) + (let ((vector (slot-value record 'coordinate-sorted-set)) + (length (slot-value record 'fill-pointer)) + (bound (slot-value record 'tallest-box-height))) + (declare (type simple-vector vector) (fixnum length bound) + #+Genera (sys:array-register vector)) + (let ((end (coordinate-sorted-set-index-for-position vector 0 (+ y bound 1) 0 length)) + (limit (- y bound))) + (declare (fixnum end limit)) + (multiple-value-bind (xoff yoff) + (output-record-position* record) + (translate-fixnum-positions (- xoff) (- yoff) x y)) + (do ((index (min (1- length) end) (the fixnum (1- (the fixnum index))))) + ((< (the fixnum index) 0)) + (declare (fixnum index)) + (let ((child (svref vector index))) + (with-bounding-rectangle* (left top right bottom) child + (when (ltrb-contains-point*-p left top right bottom x y) + (apply function child continuation-args)) + (when (< bottom limit) + (return nil)))))))) + +;; Like POSITION, but searches coordinate sorted sets +(defun coordinate-sorted-set-position (object vector fill-pointer) + (declare (type simple-vector vector) (fixnum fill-pointer)) + (declare (optimize (speed 3) (safety 0))) + (with-bounding-rectangle* (left top right bottom) object + (declare (ignore left top)) + ;; Binary search to find where this one goes. + (let ((search-index (coordinate-sorted-set-index-for-position + vector right bottom 0 fill-pointer))) + (declare (fixnum search-index)) + ;; Search back over things in the same place. + (when (< search-index fill-pointer) + (dovector ((record index) vector :start 0 :end (1+ search-index) + :from-end t :simple-p t) + (when (eq record object) + (return-from coordinate-sorted-set-position index)) + (with-bounding-rectangle* (other-left other-top other-right other-bottom) record + (declare (ignore other-left other-top)) + (unless (and (= right other-right) (= bottom other-bottom)) + (return))))) + ;; Search forward too. + (dovector ((record index) vector + :start (if (< search-index fill-pointer) (1+ search-index) 0) + :end fill-pointer :simple-p t) + (when (eq record object) + (return index) + (when (> (bounding-rectangle-bottom record) bottom) + (return nil))))))) + +;; Binary search; dictionary order Y, X. +(defun coordinate-sorted-set-index-for-position (vector right bottom start end) + (declare (type simple-vector vector) + (type fixnum start end) + (type coordinate right bottom)) + (declare (optimize (speed 3) (safety 0))) + (let ((below start) + (above end)) + (declare (fixnum below above)) + (assert (<= below above)) ;Binary search will loop otherwise. + (let (#+(or Genera Minima) (vector vector)) + #+Genera (declare (sys:array-register vector)) + #+Minima (declare (type vector vector)) + (loop + (when (= above below) + (return above)) + (let* ((index (the fixnum (ash (the fixnum (+ above below)) -1))) + (other-box (svref vector index))) + (with-bounding-rectangle* (other-left other-top other-right other-bottom) + other-box + (declare (ignore other-left other-top)) + (cond ((or (< bottom other-bottom) + (and (= bottom other-bottom) (< right other-right))) + (setq above index)) + ((or (> bottom other-bottom) + (and (= bottom other-bottom) (> right other-right))) + (if (= below index) + (return above) + (setq below index))) + (t + (return index))))))))) diff --git a/clim/genera-activities.lisp b/clim/genera-activities.lisp new file mode 100644 index 00000000..373524f0 --- /dev/null +++ b/clim/genera-activities.lisp @@ -0,0 +1,94 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: genera-activities.lisp,v 1.4 91/03/26 12:47:58 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(defvar *sheet-roots* nil) +(defvar *deactivated-clim-activities* nil) + +(scl:defflavor clim-activity + (frame-name + (frame-args nil)) + (cli::basic-activity) + (:initable-instance-variables frame-name frame-args) + (:required-init-keywords :frame-name)) + +(scl:defmethod (sys:select-activity clim-activity) + (&key console superior force-create beep-if-only-one-selected) + (cli::find-frame-for-activity console superior + #'(lambda (clim-sheet) + (when (typep clim-sheet 'clim-sheet) + (let* ((window (clim-window-for-host-window clim-sheet :error-if-no-match nil)) + (frame (and window (window-stream-to-frame window)))) + (and frame (eq (frame-name frame) frame-name))))) + #'(lambda (&rest init-keywords &key superior &allow-other-keys) + (let ((root (find superior *sheet-roots* :key #'(lambda (root) + (slot-value root 'window))))) + (unless root + (setq root (open-root-window :sheet :screen superior)) + (push root *sheet-roots*)) + (let* ((frame (dolist (frame *deactivated-clim-activities* + ;; Didn't find one, so make a new one + (with-keywords-removed (init-keywords init-keywords + '(:superior)) + (apply #'make-application-frame frame-name + :parent root + :pretty-name cli::description + (append init-keywords frame-args)))) + (when (eq (frame-name frame) frame-name) + (let ((window (frame-top-level-sheet frame))) + (when (eq (window-parent window) root) + (setq *deactivated-clim-activities* + (delete frame *deactivated-clim-activities*)) + (when (zerop (tv:sheet-dead (slot-value window 'window))) + (return frame))))))) + (window (frame-top-level-sheet frame)) + (clim-sheet (slot-value window 'window))) + (stream-clear-input window) ;might have an Abort left in it + (scl:process-run-function (frame-pretty-name frame) + #'(lambda (frame clim-sheet) + (setf (tv:io-buffer-last-output-process (scl:send clim-sheet :io-buffer)) + scl:*current-process*) + (unwind-protect (run-frame-top-level frame) + (when (zerop (tv:sheet-dead clim-sheet)) + (push frame *deactivated-clim-activities*)))) + frame clim-sheet) + clim-sheet))) + :select t + :force-create force-create + :beep-if-only-one-selected beep-if-only-one-selected)) + +(scl:defmethod (cli::activity-frame-acceptable-p clim-activity) (clim-sheet) + (and (typep clim-sheet 'clim-sheet) + (let* ((window (clim-window-for-host-window clim-sheet :error-if-no-match nil)) + (frame (and window (window-stream-to-frame window)))) + (and frame + (eql (frame-name frame) frame-name))))) + +(flavor:defmethod (x-screen::activity-acceptable-for-x-screen-p clim-activity) () t) + +(scl:compile-flavor-methods clim-activity) + + +(defmacro define-genera-application (frame-name &rest keys + &key pretty-name select-key + ;; Default edges and size for the frame + left top right bottom width height) + (declare (ignore left top right bottom width height)) + (with-keywords-removed (keys keys '(:pretty-name :select-key)) + `(define-genera-application-1 + ',frame-name ',pretty-name ',select-key ',(copy-list keys)))) + +(defun define-genera-application-1 (frame-name pretty-name select-key &optional frame-args) + (when (null pretty-name) + (setq pretty-name (command-name-from-symbol frame-name))) + (when (cli::define-activity 'clim-activity + :name pretty-name + :description pretty-name + :frame-name frame-name + :frame-args frame-args) + (when select-key + (sys:set-select-key-activity select-key pretty-name)))) diff --git a/clim/item-list-manager.lisp b/clim/item-list-manager.lisp new file mode 100644 index 00000000..5f36ed61 --- /dev/null +++ b/clim/item-list-manager.lisp @@ -0,0 +1,96 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: item-list-manager.lisp,v 1.4 91/03/26 12:48:10 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1989, 1990 International Lisp Associates. All rights reserved." + +(defclass item-list-manager () + ((item-list :initarg :item-list :accessor ilm-item-list) + (display-record :initform nil)) + (:default-initargs :item-list nil)) + +(defmethod clear-items ((ilm item-list-manager)) + (setf (slot-value ilm 'item-list) nil)) + +(defmethod add-item ((ilm item-list-manager) new-item + &key before-item after-item before-index after-index) + ;; Default is before 1st item + (unless (or before-item after-item before-index after-index) + (setq before-index 0)) + ;;--- make sure that only one argument is supplied + (with-slots (item-list) ilm + (when before-item + (setq before-index (position before-item item-list)) + (when (null before-index) + (error "Could not find :before-item ~S in item-list" before-item))) + (when after-item + (setq after-index (position after-item item-list)) + (when (null after-index) + (error "Could not find :after-item ~S in item-list" after-item))) + (cond (before-index + ;; Check bounds, but allow for empty list (add first item either :before- or :after-index 0 + #+Ignore + (assert (< -1 before-index (max 1 (length item-list))) () + "The :before-index was ~D which is outside the bounds of the item-list" + before-index) + (if (= before-index 0) + (push new-item item-list) + (push new-item (cdr (nthcdr (1- before-index) item-list))))) + (after-index + ;; Check bounds, but allow for empty list (add first item either :before- or :after-index 0 + #+Ignore + (assert (< -1 after-index (max 1 (length item-list))) () + "The :after-index was ~D which is outside the bounds of the item-list" + after-index) + (push new-item (cdr (nthcdr after-index item-list)))) + (t (error "Could not add item ~S to the item list." new-item))))) + +(defmethod delete-item ((ilm item-list-manager) item) + (with-slots (item-list) ilm + (let ((pos (position item item-list))) + (if pos + (setf item-list (delete item item-list)) + (error "Could not find item ~S in item list" item))))) + +(defmethod append-item ((ilm item-list-manager) new-item) + (with-slots (item-list) ilm + (add-item ilm new-item :before-index (length item-list)))) + +(defmethod delete-item-at-index ((ilm item-list-manager) index) + (with-slots (item-list) ilm + (assert (< -1 index (length item-list)) () + "The index was ~D which is outside the bounds of the item-list" + index) + (setf item-list (append (subseq item-list 0 index) + (nthcdr (1+ index) item-list))))) + +(defmethod map-over-items ((ilm item-list-manager) function) + (dolist (item (slot-value ilm 'item-list)) + (funcall function item))) + +;;; This is sort of kludgy. We really need to keep a per-stream cache of display-records. +(defmethod display-items ((ilm item-list-manager) stream + &key incrementally (printer #'write-string)) + (if incrementally + (display-items-incrementally ilm stream :printer printer) + (with-slots (display-record item-list) ilm + (dolist (item item-list) + (funcall printer item stream) + (terpri stream))))) + +(defmethod display-items-incrementally ((ilm item-list-manager) stream + &key (printer #'write-string)) + (with-slots (display-record item-list) ilm + (setq display-record (updating-output (stream) + (dolist (item item-list) + (updating-output (stream :unique-id item :cache-value t) + (funcall printer item stream) + (terpri stream))))))) + +(defmethod redisplay-items ((ilm item-list-manager) stream) + (with-slots (display-record) ilm + (unless display-record + (error "You must use display-items with the :incrementally option to use redisplay")) + (redisplay display-record stream))) diff --git a/clim/prefill.lisp b/clim/prefill.lisp new file mode 100644 index 00000000..6bbf0b7a --- /dev/null +++ b/clim/prefill.lisp @@ -0,0 +1,1543 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: prefill.lisp,v 1.4 91/03/26 12:48:29 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; This file prefills generic function dispatch caches at load time so that +;;; there won't be so much delay starting things up the first time the application +;;; is run. + +;;; The first page of this file contains commented-out functions for gathering the +;;; necessary information. The second page contains the prefill mechanism. The +;;; third page contains calls to the prefill mechanism, generated by running the +;;; commented-out functions after running the usual CLIM demos on both Genera and +;;; Cloe, in CLIM 13.x, and then manually massaging the results. The file +;;; CLIM:DEMO;DEMO-PREFILL contains additional prefills specific to the demos. + + +#|| + +;; Exercise the system with a synthetic load (i.e. run demos) and then +;; call this function to produce calls to PREFILL-DISPATCH-CACHES +;; corresponding to what has actually been called. You can also call +;; the function GENERATE-PREFILL-DISPATCH-CACHES on whatever classes you +;; deem interesting. This only works in Symbolics Genera and Cloe. + +(defun generate-all-prefill-dispatch-caches (&optional file) + (if file + (with-open-file (*standard-output* file :direction :output) + (generate-all-prefill-dispatch-caches)) + (let ((*print-pretty* t) + (*print-length* nil) + (*print-level* nil)) + (dolist (base-class '(transformation + ;; This gets us all kinds of windows and output records, too + design + line-style + text-style + device-font + ;; WINDOW-STREAM stuff gets listed twice, but we + ;; need ACCEPT-VALUES-STREAM, STANDARD-INPUT-EDITING-STREAM, etc. + fundamental-stream + pointer + console + device-event + view + basic-history + application-frame + command-table + noise-string + display-device + io-buffer + queue + cursor + accept-values-query + presentation-translator)) + (format t "~2%;;; ~(~S~)~2%~S" + `(generate-prefill-dispatch-caches ',base-class) + (generate-prefill-dispatch-caches base-class))) + ;; This is only the presentation types that I think all applications use + (dolist (base-class '(command command-name command-arguments keyword-argument-name + command-or-form expression + command-menu-element menu-item + completion subset-completion sequence null blank-area)) + (format t "~2%;;; ~(~S~)~2%~S" + `(generate-prefill-dispatch-caches + (find-presentation-type-class ',base-class)) + (generate-prefill-dispatch-caches + (find-presentation-type-class base-class))))))) + +(defun generate-prefill-dispatch-caches (class-name) + (let ((generic-functions nil) + (classes nil)) + (clos-internals::map-over-class-and-its-subclasses class-name + #'(lambda (class) + (pushnew (class-name class) classes) + (clos-internals::map-over-dispatch-table + #'(lambda (selector handler extra-argument) + (typecase selector + (cons + (pushnew (first selector) generic-functions)) + (clos-internals::generic-function-selector + (when (clos-internals::generic-function-clos selector) + (pushnew (clos-internals::funcallable-instance-from-generic-selector + selector) + generic-functions))) + (otherwise)) + (values selector handler extra-argument)) + (clos-internals::%instance-information-dispatch-table + (clos-internals::class-instance-information class))))) + (setq generic-functions (sort generic-functions + #'(lambda (x y) + (setq x (clos:generic-function-name x) + y (clos:generic-function-name y)) + (let ((xx (if (atom x) x (second x))) + (yy (if (atom y) y (second y)))) + (if (eq xx yy) + (or (atom x) + (and (consp y) + (string<= (first x) (first y)))) + (string<= xx yy)))))) + `(prefill-dispatch-caches + ,@(mapcar + #'(lambda (generic-function) + (let ((nargs + (length (clos-internals::dispatching-funcallable-instance-precedence-order + generic-function))) + (calls nil)) + (labels ((mapper (dispatch handler extra-argument state &rest arguments) + (declare (dynamic-extent arguments)) + (ecase (clos-internals::dispatch-type dispatch) + (clos-internals::class-dispatch + (apply #'clos-internals::generic-function-map-over-dispatch + generic-function handler extra-argument state + #'mapper + (clos-internals::class-dispatch-position dispatch) + (class-name + (clos-internals::class-dispatch-class dispatch)) + arguments)) + (clos-internals::eql-dispatch + (let ((key-or-nil + (clos-internals::eql-dispatch-key-or-nil dispatch))) + (when key-or-nil + (apply #'clos-internals::generic-function-map-over-dispatch + generic-function handler extra-argument state + #'mapper + (clos-internals::eql-dispatch-position dispatch) + `(eql ,(cond ((eq key-or-nil +foreground-ink+) + `+foreground-ink+) + ((eq key-or-nil +background-ink+) + `+background-ink+) + ((eq key-or-nil +everywhere+) + `+everywhere+) + ((eq key-or-nil +nowhere+) + `+nowhere+) + ((eq key-or-nil +flipping-ink+) + `+flipping-ink+) + ((typep key-or-nil '(or number + character + (member t nil) + keyword)) + key-or-nil) + (t `',key-or-nil))) + arguments)))) + (clos-internals::finish-dispatch + (when (do ((l arguments (cddr l))) + ((null l) nil) + (when (member (second l) classes) + (return t))) + (pushnew (do ((i (1- nargs) (1- i)) + (l nil)) + ((< i 0) l) + (push (getf arguments i 't) l)) + calls :test #'equal)))) + (values handler extra-argument))) + (clos-internals::map-over-generic-function-computed-dispatches + generic-function #'mapper) + `(,(clos:generic-function-name generic-function) + ,@calls)))) + generic-functions)))) +||# + +;;; Prefill dispatch caches for a bunch of generic function calls +(defmacro prefill-dispatch-caches (&body clauses &environment env) + (let (function) + (labels ((expand-clause (clause) + (setq function (car clause)) + (unless (clos-internals::fboundp-in-environment function env) + #+++ignore ;until we fix CLOS + (warn "prefill-dispatch-caches: ~S is not a defined generic function." + function)) + (mapcan #'expand-call (cdr clause))) + (expand-call (args) + (dolist (arg args) + (unless (cond ((atom arg) (find-class arg nil env)) + ((eq (first arg) 'eql) t) + ((eq (first arg) 'presentation-type) + (find-presentation-type-class (second arg) nil env))) + #+++ignore ;until we fix CLOS + (warn "prefill-dispatch-caches: ~S is not a valid specializer in the ~ + arguments to ~S." + arg function))) + `(',function + ,(if (some #'needs-evaluation args) + `(list ,@(mapcar #'(lambda (arg) + (if (and (consp arg) (eq (first arg) 'eql)) + ``(eql ,,(second arg)) + ``,',arg)) + args)) + `',(mapcar #'(lambda (arg) + (if (and (consp arg) (eq (first arg) 'eql)) + `(eql ,(eval (second arg))) + arg)) + args)))) + (needs-evaluation (arg) + (and (consp arg) + (eq (first arg) 'eql) + (not (if (consp (second arg)) + (eq (first (second arg)) 'quote) + (typep (second arg) + '(or number character keyword (member t nil)))))))) + `(prefill-dispatch-caches-1 + ,@(mapcan #'expand-clause clauses))))) + +(defun prefill-dispatch-caches-1 (&rest calls) + (declare (dynamic-extent calls)) + (dorest (calls calls cddr) + (let ((generic-function + (and (clos-internals::fboundp-in-environment (first calls) nil) + (clos-internals::fdefinition-in-environment (first calls) nil))) + (arguments (mapcar #'(lambda (arg) + (setq arg (cond ((atom arg) (find-class arg)) + ((eq (first arg) 'eql) arg) + ((eq (first arg) 'presentation-type) + (find-presentation-type-class (second arg))) + (t + (error "Invalid argument specification: ~S" + arg)))) + (when (typep arg 'class) + (unless (clos-internals::class-finalized-p arg) + (clos-internals::finalize-inheritance arg))) + arg) + (second calls)))) + (unless (typep generic-function 'generic-function) + (error "~S is not a defined generic function." (first calls))) + #+Symbolics ;Symbolics CLOS, that is + (clos-internals::generic-function-ensure-specializers-mapped + generic-function arguments #'clos-internals::standard-method-combiner) + #-Symbolics + (error "I don't know how to prefill generic function dispatch caches except in Symbolics CLOS")))) + + +;;; This page contains the non-demo-specific results after running the demos in +;;; both Genera and Cloe. Some things have been commented out since they didn't +;;; seem important, machine-dependent things have been conditionalized, and +;;; demo-specific things have been moved to the demo specific file. Otherwise +;;; the only hand-massaging was to standardize the pretty printing and remove +;;; some duplicate entries and things only used when printing internal objects. + +;;; (generate-prefill-dispatch-caches 'transformation) + +(PREFILL-DISPATCH-CACHES + (COMPOSE-TRANSFORMATIONS + (IDENTITY-TRANSFORMATION STANDARD-TRANSFORMATION) + (IDENTITY-TRANSFORMATION TRANSLATION-TRANSFORMATION) + (TRANSLATION-TRANSFORMATION STANDARD-TRANSFORMATION) + (STANDARD-TRANSFORMATION TRANSLATION-TRANSFORMATION) + (STANDARD-TRANSFORMATION STANDARD-TRANSFORMATION) + (STANDARD-TRANSFORMATION IDENTITY-TRANSFORMATION)) + #+Genera (CLOS-INTERNALS:OPERATION-HANDLED-P (TRANSLATION-TRANSFORMATION T) + (IDENTITY-TRANSFORMATION T) + (STANDARD-TRANSFORMATION T)) + (RECTILINEAR-TRANSFORMATION-P (IDENTITY-TRANSFORMATION) + (STANDARD-TRANSFORMATION)) + (TRANSFORM-DISTANCE (STANDARD-TRANSFORMATION T T) + (IDENTITY-TRANSFORMATION T T)) + (TRANSFORM-POINT* (IDENTITY-TRANSFORMATION T T) + (STANDARD-TRANSFORMATION T T))) + + +;;; (generate-prefill-dispatch-caches 'design) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-1 + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-ADD-CHARACTER-OUTPUT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T)) + (ADD-CHARACTER-OUTPUT-TO-TEXT-RECORD + (STANDARD-TEXT-OUTPUT-RECORD T T T T T) + (STYLED-TEXT-OUTPUT-RECORD T T T T T)) + (STREAM-ADD-OUTPUT-RECORD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (ADD-OUTPUT-RECORD (T STANDARD-CELL-OUTPUT-RECORD) + (T STANDARD-PRESENTATION) + (T STANDARD-ITEM-LIST-OUTPUT-RECORD) + (T STANDARD-SEQUENCE-OUTPUT-RECORD) + (T STANDARD-TREE-OUTPUT-HISTORY) + (T STANDARD-UPDATING-OUTPUT-RECORD) + (T ACCEPT-VALUES-OUTPUT-RECORD) + (T STANDARD-ROW-OUTPUT-RECORD) + (T BORDER-OUTPUT-RECORD) + (T STANDARD-TABLE-OUTPUT-RECORD)) + (STREAM-ADD-STRING-OUTPUT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T)) + (ADD-STRING-OUTPUT-TO-TEXT-RECORD + (STANDARD-TEXT-OUTPUT-RECORD T T T T T T T) + (STYLED-TEXT-OUTPUT-RECORD T T T T T T T)) + (ADJUST-TABLE-CELLS (STANDARD-ITEM-LIST-OUTPUT-RECORD) (STANDARD-TABLE-OUTPUT-RECORD) (STANDARD-ROW-OUTPUT-RECORD)) + (BOUNDING-RECTANGLE* + #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW) + (STANDARD-BOUNDING-RECTANGLE) + (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD) + (STANDARD-TREE-OUTPUT-HISTORY) + (POLYGON-DISPLAYED-OUTPUT-RECORD) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD) + (LINE-DISPLAYED-OUTPUT-RECORD) + (RECTANGLE-DISPLAYED-OUTPUT-RECORD) + (STRING-DISPLAYED-OUTPUT-RECORD) + (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-POINT) + (STANDARD-TABLE-OUTPUT-RECORD) + (BORDER-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD)) + (BOUNDING-RECTANGLE-SET-EDGES + (STANDARD-SEQUENCE-OUTPUT-RECORD T T T T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T T T T) + (STANDARD-PRESENTATION T T T T) + (STANDARD-CELL-OUTPUT-RECORD T T T T) + (STANDARD-TEXT-OUTPUT-RECORD T T T T) + (STYLED-TEXT-OUTPUT-RECORD T T T T) + (STANDARD-TREE-OUTPUT-HISTORY T T T T) + #+Cloe-Runtime (CLOE-ROOT-WINDOW T T T T) + #+Cloe-Runtime (CLOE-WINDOW-STREAM T T T T) + #+Genera (SHEET-WINDOW-STREAM T T T T) + #+Minima (CLX-WINDOW T T T T) + (POLYGON-DISPLAYED-OUTPUT-RECORD T T T T) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD T T T T) + (LINE-DISPLAYED-OUTPUT-RECORD T T T T) + (RECTANGLE-DISPLAYED-OUTPUT-RECORD T T T T) + (STRING-DISPLAYED-OUTPUT-RECORD T T T T) + (STANDARD-UPDATING-OUTPUT-RECORD T T T T) + (ACCEPT-VALUES-OUTPUT-RECORD T T T T) + (STANDARD-TABLE-OUTPUT-RECORD T T T T) + (BORDER-OUTPUT-RECORD T T T T) + (STANDARD-ROW-OUTPUT-RECORD T T T T)) + (BOUNDING-RECTANGLE-SET-POSITION* + (STANDARD-TREE-OUTPUT-HISTORY T T) + (STANDARD-CELL-OUTPUT-RECORD T T) + (STANDARD-BOUNDING-RECTANGLE T T) + #+Cloe-Runtime (CLOE-ROOT-WINDOW T T) + #+Cloe-Runtime (CLOE-WINDOW-STREAM T T) + #+Genera (SHEET-WINDOW-STREAM T T) + #+Minima (CLX-WINDOW T T) + (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T) + (STANDARD-PRESENTATION T T) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD T T) + (LINE-DISPLAYED-OUTPUT-RECORD T T)) + (BOUNDING-RECTANGLE-SET-SIZE + (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T) + #+Cloe-Runtime (CLOE-ROOT-WINDOW T T) + #+Cloe-Runtime (CLOE-WINDOW-STREAM T T) + #+Genera (SHEET-WINDOW-STREAM T T) + #+Minima (CLX-WINDOW T T) + (STANDARD-BOUNDING-RECTANGLE T T)) + (CACHE-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T)) + (CLEAR-OUTPUT-HISTORY + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (CLEAR-OUTPUT-RECORD (STANDARD-TREE-OUTPUT-HISTORY) + (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD)) + #+Cloe-Runtime (CLOE-PROCESS-DEFERRED-EVENTS (CLOE-WINDOW-STREAM)) + #+Cloe-Runtime (CLOE-RECOMPUTE-SCROLL-BARS (CLOE-WINDOW-STREAM)) + (STREAM-CLOSE-TEXT-OUTPUT-RECORD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (COLOR-RGB (GRAY-COLOR) (RGB-COLOR)) + (COMPUTE-DIFFERENCES (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD) + (LINE-DISPLAYED-OUTPUT-RECORD)) + (COPY-AREA + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T)) + (COPY-DISPLAY-STATE (STANDARD-UPDATING-OUTPUT-RECORD T) + (ACCEPT-VALUES-OUTPUT-RECORD T) + (STANDARD-PRESENTATION T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T) + (STANDARD-CELL-OUTPUT-RECORD T)) + #+Cloe-Runtime (DC-IMAGE-FOR-INK (T GRAY-COLOR) + (T FLIPPING-INK) + (T RGB-COLOR) + (T (EQL +BLACK+)) + (T (EQL +WHITE+)) + (T (EQL +FOREGROUND-INK+)) + (T (EQL +BACKGROUND-INK+))) + (DECACHE-INFERIOR-OUTPUT-RECORD (ACCEPT-VALUES-OUTPUT-RECORD T T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T T) + (STANDARD-UPDATING-OUTPUT-RECORD T T)) + (DECODE-FLIPPING-INK (FLIPPING-INK)) + (DECODE-PATTERN (PATTERN)) + (DECODE-RECTANGULAR-TILE (RECTANGULAR-TILE)) + (DECODE-STREAM-FOR-WRITING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (DELETE-OUTPUT-RECORD (T ACCEPT-VALUES-OUTPUT-RECORD) + (T STANDARD-TREE-OUTPUT-HISTORY) + (T STANDARD-SEQUENCE-OUTPUT-RECORD)) + (DO-TEXT-SCREEN-REAL-ESTATE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T T)) + (DRAW-ELLIPSE-INTERNAL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T T T T)) + (DRAW-ELLIPSE-METHOD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T)) + (DRAW-LINE-INTERNAL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T)) + (DRAW-LINE-METHOD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T)) + (DRAW-POLYGON-INTERNAL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T)) + (DRAW-POLYGON-METHOD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T)) + (DRAW-RECTANGLE-INTERNAL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T)) + (DRAW-RECTANGLE-METHOD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T)) + (DRAW-STRING-INTERNAL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T T T)) + (DRAW-STRING-METHOD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T))) + +(PREFILL-DISPATCH-CACHES + (DRAWING-SURFACE-TO-VIEWPORT-COORDINATES + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (INFERIORS-NEVER-OVERLAP-P (STANDARD-UPDATING-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD)) + (ENCODE-STREAM-AFTER-WRITING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T)) + (EXTENDED-OUTPUT-STREAM-P #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (FIND-CACHED-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T)) + (FIND-INFERIOR-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T) + (STANDARD-PRESENTATION T T) + (STANDARD-CELL-OUTPUT-RECORD T T)) + (FIND-QUERY (ACCEPT-VALUES-OUTPUT-RECORD T)) + (INVOKE-FORMATTING-CELL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + + (GET-TEXT-OUTPUT-RECORD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STYLIZE-TEXT-OUTPUT-RECORD + (STANDARD-TEXT-OUTPUT-RECORD T T)) + (GRAPHICS-STREAM-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (HIGHLIGHT-OUTPUT-RECORD-1 (STANDARD-PRESENTATION T T) + (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T)) + (HOST-WINDOW-MARGINS #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (INCREMENTAL-REDISPLAY + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T)) + (INFERIOR-OUTPUT-RECORD-CHANGED (STANDARD-TREE-OUTPUT-HISTORY T T T T T)) + (INITIALIZE-MENU + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (INPUT-EDITING-STREAM-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MAKE-GRAY-COLOR-FOR-CONTRASTING-INK (CONTRASTING-INK)) + (MAP-OVER-MENU-CELLS (STANDARD-ITEM-LIST-OUTPUT-RECORD T)) + (MAP-OVER-OUTPUT-RECORDS-CONTAINING-POINT* + (T STANDARD-TREE-OUTPUT-HISTORY T T) + (T STANDARD-SEQUENCE-OUTPUT-RECORD T T) + (T STANDARD-ITEM-LIST-OUTPUT-RECORD T T) + (T STANDARD-PRESENTATION T T) + (T STANDARD-CELL-OUTPUT-RECORD T T) + (T STANDARD-TEXT-OUTPUT-RECORD T T) + (T STYLED-TEXT-OUTPUT-RECORD T T) + (T STANDARD-UPDATING-OUTPUT-RECORD T T) + (T STRING-DISPLAYED-OUTPUT-RECORD T T) + (T POLYGON-DISPLAYED-OUTPUT-RECORD T T) + (T ELLIPSE-DISPLAYED-OUTPUT-RECORD T T) + (T ACCEPT-VALUES-OUTPUT-RECORD T T) + (T LINE-DISPLAYED-OUTPUT-RECORD T T) + (T STANDARD-TABLE-OUTPUT-RECORD T T) + (T STANDARD-ROW-OUTPUT-RECORD T T) + (T RECTANGLE-DISPLAYED-OUTPUT-RECORD T T) + (T BORDER-OUTPUT-RECORD T T)) + (MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION + (T STANDARD-TREE-OUTPUT-HISTORY T) + (T STANDARD-SEQUENCE-OUTPUT-RECORD T) + (T STANDARD-ITEM-LIST-OUTPUT-RECORD T) + (T STANDARD-PRESENTATION T) + (T STANDARD-CELL-OUTPUT-RECORD T) + (T STANDARD-TEXT-OUTPUT-RECORD T) + (T STYLED-TEXT-OUTPUT-RECORD T) + (T STANDARD-UPDATING-OUTPUT-RECORD T) + (T STRING-DISPLAYED-OUTPUT-RECORD T) + (T POLYGON-DISPLAYED-OUTPUT-RECORD T) + (T ELLIPSE-DISPLAYED-OUTPUT-RECORD T) + (T LINE-DISPLAYED-OUTPUT-RECORD T) + (T ACCEPT-VALUES-OUTPUT-RECORD T) + (T STANDARD-ROW-OUTPUT-RECORD T) + (T STANDARD-TABLE-OUTPUT-RECORD T) + (T BORDER-OUTPUT-RECORD T)) + (MAP-OVER-ROW-CELLS (T STANDARD-ROW-OUTPUT-RECORD)) + (MAP-OVER-TABLE-ELEMENTS (T STANDARD-ITEM-LIST-OUTPUT-RECORD T) + (T STANDARD-PRESENTATION T) + (T STANDARD-UPDATING-OUTPUT-RECORD T) + (T STANDARD-TABLE-OUTPUT-RECORD T) + (T STANDARD-SEQUENCE-OUTPUT-RECORD T) + (T STANDARD-ROW-OUTPUT-RECORD T)) + (MAP-OVER-TABLE-ELEMENTS-HELPER (T STANDARD-PRESENTATION T) + (T STANDARD-CELL-OUTPUT-RECORD T) + (T STANDARD-UPDATING-OUTPUT-RECORD T) + (T BORDER-OUTPUT-RECORD T) + (T STANDARD-ROW-OUTPUT-RECORD T)) + (MAP-OVER-TABLE-ROWS (T STANDARD-TABLE-OUTPUT-RECORD)) + (MAP-OVER-TABLE-ROWS-OR-COLUMNS (T STANDARD-TABLE-OUTPUT-RECORD)) + (MATCH-OUTPUT-RECORDS (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD)) + (MAYBE-SET-COLOR (POSTSCRIPT-STREAM GRAY-COLOR) + (POSTSCRIPT-STREAM (EQL +BACKGROUND-INK+)) + (POSTSCRIPT-STREAM (EQL +FOREGROUND-INK+))) + (MEDIUM-BACKGROUND + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MEDIUM-FOREGROUND + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MEDIUM-DEFAULT-TEXT-STYLE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF MEDIUM-DEFAULT-TEXT-STYLE) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MEDIUM-INK + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MEDIUM-LINE-STYLE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MEDIUM-TEXT-STYLE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF MEDIUM-TEXT-STYLE) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (MEDIUM-TRANSFORMATION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + #+Genera (MOUSE-DOCUMENTATION-WINDOW (SHEET-WINDOW-STREAM)) + (NEW-OUTPUT-RECORDS (STANDARD-UPDATING-OUTPUT-RECORD T)) + (NOTIFY-USER-1 #+Genera (SHEET-WINDOW-STREAM T T) + #+Minima (CLX-WINDOW T T) + #+Cloe-Runtime (CLOE-WINDOW-STREAM T T)) + (OPACITY-VALUE (CLIM-UTILS::EVERYWHERE)) + #+Genera (CLOS-INTERNALS:OPERATION-HANDLED-P (SHEET-WINDOW-STREAM T) + (DESIGN T) + (FLIPPING-INK T))) + +(PREFILL-DISPATCH-CACHES + (OUTPUT-RECORD-CACHE-VALUE (STANDARD-UPDATING-OUTPUT-RECORD)) + ((SETF OUTPUT-RECORD-CACHE-VALUE) (T STANDARD-UPDATING-OUTPUT-RECORD)) + (OUTPUT-RECORD-CONTENTS-OK (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD)) + (OUTPUT-RECORD-COUNT (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-TREE-OUTPUT-HISTORY) + (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (BORDER-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD)) + (OUTPUT-RECORD-CHILDREN (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD)) + (OUTPUT-RECORD-END-CURSOR-POSITION* (STANDARD-UPDATING-OUTPUT-RECORD)) + (OUTPUT-RECORD-FIXED-POSITION (STANDARD-UPDATING-OUTPUT-RECORD)) + (OUTPUT-RECORD-GENERATION-TICK (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD)) + ((SETF OUTPUT-RECORD-GENERATION-TICK) + (T STANDARD-UPDATING-OUTPUT-RECORD) + (T ACCEPT-VALUES-OUTPUT-RECORD) + (T STANDARD-PRESENTATION) + (T STANDARD-ITEM-LIST-OUTPUT-RECORD) + (T STANDARD-CELL-OUTPUT-RECORD)) + (OUTPUT-RECORD-OLD-CHILDREN (STANDARD-UPDATING-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-ITEM-LIST-OUTPUT-RECORD)) + ((SETF OUTPUT-RECORD-OLD-CHILDREN) (T STANDARD-UPDATING-OUTPUT-RECORD) + (T STANDARD-CELL-OUTPUT-RECORD)) + (OUTPUT-RECORD-OLD-BOUNDING-RECTANGLE (STANDARD-UPDATING-OUTPUT-RECORD)) + ((SETF OUTPUT-RECORD-OLD-PARENT) (T STANDARD-UPDATING-OUTPUT-RECORD)) + (OUTPUT-RECORD-OLD-CURSOR-POSITION (STANDARD-UPDATING-OUTPUT-RECORD)) + (OUTPUT-RECORD-OLD-START-CURSOR-POSITION (STANDARD-UPDATING-OUTPUT-RECORD)) + (OUTPUT-RECORD-OLD-START-CURSOR-POSITION* (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD)) + (OUTPUT-RECORD-PARENT (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-TREE-OUTPUT-HISTORY) + (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (BORDER-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD)) + ((SETF OUTPUT-RECORD-PARENT) + (T STANDARD-TEXT-OUTPUT-RECORD) + (T STYLED-TEXT-OUTPUT-RECORD) + (T STANDARD-CELL-OUTPUT-RECORD) + (T STANDARD-PRESENTATION) + (T STANDARD-ITEM-LIST-OUTPUT-RECORD) (T STANDARD-SEQUENCE-OUTPUT-RECORD) + (T POLYGON-DISPLAYED-OUTPUT-RECORD) (T ELLIPSE-DISPLAYED-OUTPUT-RECORD) + (T LINE-DISPLAYED-OUTPUT-RECORD) (T RECTANGLE-DISPLAYED-OUTPUT-RECORD) + (T STRING-DISPLAYED-OUTPUT-RECORD) (T STANDARD-UPDATING-OUTPUT-RECORD) (T ACCEPT-VALUES-OUTPUT-RECORD) + (T STANDARD-ROW-OUTPUT-RECORD) (T BORDER-OUTPUT-RECORD) (T STANDARD-TABLE-OUTPUT-RECORD)) + (OUTPUT-RECORD-REFINED-SENSITIVITY-TEST (STANDARD-PRESENTATION T T) + (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T) + (LINE-DISPLAYED-OUTPUT-RECORD T T) + (STRING-DISPLAYED-OUTPUT-RECORD T T) + (RECTANGLE-DISPLAYED-OUTPUT-RECORD T T) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD T T) + (POLYGON-DISPLAYED-OUTPUT-RECORD T T)) + (OUTPUT-RECORD-SET-END-CURSOR-POSITION* (STANDARD-CELL-OUTPUT-RECORD T T) + (STANDARD-PRESENTATION T T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T T) + (STANDARD-SEQUENCE-OUTPUT-RECORD T T) + (STANDARD-UPDATING-OUTPUT-RECORD T T) + (ACCEPT-VALUES-OUTPUT-RECORD T T) + (STANDARD-TREE-OUTPUT-HISTORY T T) + (STANDARD-ROW-OUTPUT-RECORD T T) + (BORDER-OUTPUT-RECORD T T) + (STANDARD-TABLE-OUTPUT-RECORD T T)) + (OUTPUT-RECORD-SET-OLD-START-CURSOR-POSITION* (STANDARD-UPDATING-OUTPUT-RECORD T T) + (ACCEPT-VALUES-OUTPUT-RECORD T T) + (STANDARD-PRESENTATION T T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T T) + (STANDARD-CELL-OUTPUT-RECORD T T)) + (OUTPUT-RECORD-SET-START-CURSOR-POSITION* (STANDARD-SEQUENCE-OUTPUT-RECORD T T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T T) + (STANDARD-PRESENTATION T T) + (STANDARD-CELL-OUTPUT-RECORD T T) + (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T) + (STANDARD-UPDATING-OUTPUT-RECORD T T) + (ACCEPT-VALUES-OUTPUT-RECORD T T) + (STANDARD-TABLE-OUTPUT-RECORD T T) + (BORDER-OUTPUT-RECORD T T) + (STANDARD-ROW-OUTPUT-RECORD T T)) + (OUTPUT-RECORD-START-CURSOR-POSITION (STANDARD-TREE-OUTPUT-HISTORY)) + (OUTPUT-RECORD-START-CURSOR-POSITION* (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-TREE-OUTPUT-HISTORY) + (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD) + (STRING-DISPLAYED-OUTPUT-RECORD) + (POLYGON-DISPLAYED-OUTPUT-RECORD) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD) + (LINE-DISPLAYED-OUTPUT-RECORD) + (STANDARD-UPDATING-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (BORDER-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD)) + (OUTPUT-RECORD-UNIQUE-ID (STANDARD-UPDATING-OUTPUT-RECORD) + (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD)) + (STREAM-CURRENT-OUTPUT-RECORD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-CURRENT-OUTPUT-RECORD) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-HIGHLIGHTED-PRESENTATION) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-OUTPUT-HISTORY + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-OUTPUT-HISTORY) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-OUTPUT-HISTORY-POSITION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (OUTPUT-RECORDING-STREAM-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-CURRENT-REDISPLAY-RECORD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-CURRENT-REDISPLAY-RECORD) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-REPLAY + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-TEXT-OUTPUT-RECORD + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-TEXT-OUTPUT-RECORD) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (OUTPUT-STREAM-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (POINT-POSITION* (STANDARD-POINT)) + (POINT-X (STANDARD-POINT)) + ((SETF POINT-X) (T STANDARD-POINT)) + (POINT-Y (STANDARD-POINT)) + ((SETF POINT-Y) (T STANDARD-POINT))) + +(PREFILL-DISPATCH-CACHES + (POINTER-MOTION-PENDING + (#+Genera SHEET-WINDOW-STREAM #+Cloe-Runtime CLOE-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF POINTER-MOTION-PENDING) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (PREPARE-TEXT-RECORD-FOR-APPENDING (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T)) + (PRESENTATION-OBJECT (STANDARD-PRESENTATION)) + ((SETF PRESENTATION-OBJECT) (T STANDARD-PRESENTATION)) + (PRESENTATION-SINGLE-BOX (STANDARD-PRESENTATION)) + (PRESENTATION-TYPE (STANDARD-PRESENTATION)) + #+Genera (PRINT-OBJECT (FLIPPING-INK T) + ((EQL +FOREGROUND-INK+) T) + ((EQL +BACKGROUND-INK+) T)) + #+Genera (CLOS-INTERNALS::PRINT-SELF (DESIGN T T T) (FLIPPING-INK T T T)) + (PROMPT-FOR-ACCEPT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (PROPAGATE-INFERIOR-OUTPUT-RECORD-CHANGES-P (STANDARD-TREE-OUTPUT-HISTORY T T)) + (RECOMPUTE-CONTENTS-OK (STANDARD-TEXT-OUTPUT-RECORD) + (STYLED-TEXT-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-UPDATING-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD)) + (RECOMPUTE-EXTENT (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-TREE-OUTPUT-HISTORY) + (STANDARD-UPDATING-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD) + (ACCEPT-VALUES-OUTPUT-RECORD) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (STANDARD-PRESENTATION)) + (RECOMPUTE-EXTENT-FOR-CHANGED-CHILD (STANDARD-SEQUENCE-OUTPUT-RECORD T T T T T) + (STANDARD-TREE-OUTPUT-HISTORY T T T T T) + (STANDARD-UPDATING-OUTPUT-RECORD T T T T T) + (ACCEPT-VALUES-OUTPUT-RECORD T T T T T) + (STANDARD-TABLE-OUTPUT-RECORD T T T T T) + (STANDARD-CELL-OUTPUT-RECORD T T T T T) + (STANDARD-ROW-OUTPUT-RECORD T T T T T) + (STANDARD-PRESENTATION T T T T T)) + (RECOMPUTE-EXTENT-FOR-NEW-CHILD (STANDARD-CELL-OUTPUT-RECORD T) + (STANDARD-PRESENTATION T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T) + (STANDARD-SEQUENCE-OUTPUT-RECORD T) + (STANDARD-TREE-OUTPUT-HISTORY T) + (STANDARD-UPDATING-OUTPUT-RECORD T) + (ACCEPT-VALUES-OUTPUT-RECORD T) + (STANDARD-ROW-OUTPUT-RECORD T) + (STANDARD-TABLE-OUTPUT-RECORD T)) + (RECOMPUTE-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T T T T T T T)) + (REDISPLAY-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T)) + (REDISPLAY-DECORATIONS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (REGION-CONTAINS-POINT*-P (STANDARD-PRESENTATION T T) + (STANDARD-TEXT-OUTPUT-RECORD T T) + (STYLED-TEXT-OUTPUT-RECORD T T) + (LINE-DISPLAYED-OUTPUT-RECORD T T)) + (REGION-INTERSECTS-REGION-P (POLYGON-DISPLAYED-OUTPUT-RECORD RECTANGLE-DISPLAYED-OUTPUT-RECORD) + (POLYGON-DISPLAYED-OUTPUT-RECORD POLYGON-DISPLAYED-OUTPUT-RECORD) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD ELLIPSE-DISPLAYED-OUTPUT-RECORD) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD POLYGON-DISPLAYED-OUTPUT-RECORD) + (STANDARD-PRESENTATION STANDARD-PRESENTATION) + (STANDARD-PRESENTATION POLYGON-DISPLAYED-OUTPUT-RECORD) + (LINE-DISPLAYED-OUTPUT-RECORD LINE-DISPLAYED-OUTPUT-RECORD) + (LINE-DISPLAYED-OUTPUT-RECORD ELLIPSE-DISPLAYED-OUTPUT-RECORD) + (RECTANGLE-DISPLAYED-OUTPUT-RECORD POLYGON-DISPLAYED-OUTPUT-RECORD) + (RECTANGLE-DISPLAYED-OUTPUT-RECORD RECTANGLE-DISPLAYED-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD STANDARD-UPDATING-OUTPUT-RECORD)) + (REPLAY-OUTPUT-RECORD (STANDARD-TREE-OUTPUT-HISTORY T) + (STANDARD-SEQUENCE-OUTPUT-RECORD T) + (STANDARD-ITEM-LIST-OUTPUT-RECORD T) + (STANDARD-PRESENTATION T) + (STANDARD-CELL-OUTPUT-RECORD T) + (STANDARD-TEXT-OUTPUT-RECORD T) + (STYLED-TEXT-OUTPUT-RECORD T) + (ELLIPSE-DISPLAYED-OUTPUT-RECORD T) + (LINE-DISPLAYED-OUTPUT-RECORD T) + (POLYGON-DISPLAYED-OUTPUT-RECORD T) + (RECTANGLE-DISPLAYED-OUTPUT-RECORD T) + (STRING-DISPLAYED-OUTPUT-RECORD T) + (STANDARD-UPDATING-OUTPUT-RECORD T) + (ACCEPT-VALUES-OUTPUT-RECORD T) + (STANDARD-TABLE-OUTPUT-RECORD T) + (BORDER-OUTPUT-RECORD T) + (STANDARD-ROW-OUTPUT-RECORD T)) + (REPOSITION-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T T T T)) + (ROW-TABLE-P (STANDARD-TABLE-OUTPUT-RECORD)) + #+Genera (CLOS-INTERNALS::SEND-IF-HANDLES (SHEET-WINDOW-STREAM T)) + (OUTPUT-RECORD-SET-POSITION* (STANDARD-TREE-OUTPUT-HISTORY T T) + (STANDARD-CELL-OUTPUT-RECORD T T)) + (SET-POINTER-WINDOW-AND-LOCATION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + #+Genera (SET-STREAM-POINTER-IN-SCREEN-COORDINATES (SHEET-WINDOW-STREAM T T T)) + (SHARED-INITIALIZE #+Cloe-Runtime (CLOE-ROOT-WINDOW T) + #+Cloe-Runtime (CLOE-WINDOW-STREAM T) + #+Genera (SHEET-WINDOW-STREAM T) + #+Minima (CLX-WINDOW T) + (ACCEPT-VALUES-OUTPUT-RECORD T)) + #+Genera (SHEET-DECODE-COLOR (GRAY-COLOR T) + (RGB-COLOR T)) + #+Genera (SHEET-DECODE-INK (FLIPPING-INK T) + (GRAY-COLOR T) + (RGB-COLOR T) + (CONTRASTING-INK T) + (RECTANGULAR-TILE T) + (PATTERN T)) + #+Genera (SHEET-DECODE-PATTERN (PATTERN T)) + (STREAM-ADVANCE-CURSOR-LINE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-BASELINE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-BASELINE) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-CHARACTER-SIZE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-CHARACTER-WIDTH + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-CLEAR-INPUT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + #+Genera (STREAM-COMPATIBLE-CURSOR-POSITION* (SHEET-WINDOW-STREAM)) + #+Genera (STREAM-COMPATIBLE-OUTPUT-AS-PRESENTATION-1 (SHEET-WINDOW-STREAM T T)) + #+Genera (STREAM-COMPATIBLE-READ-CHAR (SHEET-WINDOW-STREAM)) + #+Genera (STREAM-COMPATIBLE-SIZE-IN-CHARACTERS (SHEET-WINDOW-STREAM)) + (STREAM-CURRENT-LINE-HEIGHT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-CURRENT-LINE-HEIGHT) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-CURSOR-POSITION* #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (STREAM-DEFAULT-TEXT-MARGIN + #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + ((SETF STREAM-DEFAULT-TEXT-MARGIN) + #+Cloe-Runtime (T CLOE-ROOT-WINDOW) + #+Cloe-Runtime (T CLOE-WINDOW-STREAM) + #+Genera (T SHEET-WINDOW-STREAM) + #+Minima (T CLX-WINDOW)) + (STREAM-DEFAULT-VIEW + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-DEFAULT-VIEW) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-DRAWING-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-DRAWING-P) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-END-OF-LINE-ACTION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-END-OF-LINE-ACTION) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-END-OF-PAGE-ACTION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-END-OF-PAGE-ACTION) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))) + +(PREFILL-DISPATCH-CACHES + (STREAM-ENSURE-CURSOR-VISIBLE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-EVENT-HANDLER #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (STREAM-FINISH-OUTPUT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-FORCE-OUTPUT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-FRESH-LINE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-GLYPH-FOR-CHARACTER + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (STREAM-HANDLE-LINE-WRAP + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T)) + (STREAM-INPUT-BUFFER + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-INPUT-WAIT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-LINE-HEIGHT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-MERGED-TEXT-STYLE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-MERGED-TEXT-STYLE-VALID + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-MERGED-TEXT-STYLE-VALID) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-MOVE-FOR-LINE-HEIGHT-CHANGE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T)) + (STREAM-NOTE-LINE-HEIGHT-CHANGE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T)) + (STREAM-NOTE-POINTER-BUTTON-PRESS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T)) + (STREAM-OUTPUT-GLYPH-BUFFER + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-POINTER-POSITION* + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-POINTERS #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + ((SETF STREAM-POINTERS) #+Cloe-Runtime (T CLOE-ROOT-WINDOW) + #+Genera (T SHEET-WINDOW-STREAM) + #+Minima (T CLX-WINDOW)) + (STREAM-PRIMARY-POINTER #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (STREAM-READ-CHAR + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-READ-GESTURE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-RECORDING-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-RECORDING-P) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (REDISPLAYABLE-STREAM-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-REDISPLAYING-P + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF STREAM-REDISPLAYING-P) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-RESTORE-INPUT-FOCUS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-SCAN-CHARACTER-FOR-WRITING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T)) + (STREAM-SCAN-STRING-FOR-WRITING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T)) + (STREAM-SET-CURSOR-POSITION* + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (STREAM-SET-CURSOR-POSITION*-INTERNAL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (STREAM-SET-INPUT-FOCUS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-SET-POINTER-POSITION* + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (STREAM-STRING-OUTPUT-SIZE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-STRING-WIDTH + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-SUPPORTS-INPUT-EDITING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-TEXT-CURSOR + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-TEXT-MARGIN + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-UNREAD-GESTURE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-VERTICAL-SPACING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (STREAM-WRITE-CHAR + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-WRITE-CHAR-1 + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T)) + (STREAM-WRITE-STRING + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (STREAM-WRITE-STRING-1 + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T)) + (TREE-RECOMPUTE-EXTENT-1 (STANDARD-ITEM-LIST-OUTPUT-RECORD) + (STANDARD-PRESENTATION) + (STANDARD-CELL-OUTPUT-RECORD) + (STANDARD-UPDATING-OUTPUT-RECORD) + (STANDARD-TABLE-OUTPUT-RECORD) + (BORDER-OUTPUT-RECORD) + (STANDARD-SEQUENCE-OUTPUT-RECORD) + (STANDARD-ROW-OUTPUT-RECORD) + (LINE-DISPLAYED-OUTPUT-RECORD)) + (VIEWPORT-TO-DRAWING-SURFACE-COORDINATES + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + #+Genera (CLOS-INTERNALS::WHICH-OPERATIONS (DESIGN) (FLIPPING-INK))) + +(PREFILL-DISPATCH-CACHES + (WINDOW-BEEP + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-CHILDREN #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + ((SETF WINDOW-CHILDREN) #+Cloe-Runtime (T CLOE-ROOT-WINDOW) + #+Cloe-Runtime (T CLOE-WINDOW-STREAM) + #+Genera (T SHEET-WINDOW-STREAM) + #+Minima (T CLX-WINDOW)) + (WINDOW-CLEAR + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-CLEAR-AREA + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T)) + (WINDOW-ERASE-VIEWPORT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-EXPOSE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-FLUSH-UPDATE-REGION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-INSIDE-EDGES #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (WINDOW-INSIDE-SIZE #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (WINDOW-INSIDE-WIDTH + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-LABEL + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF WINDOW-LABEL) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-LABEL-SIZE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-MARGINS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-PARENT #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (WINDOW-PROCESS-UPDATE-REGION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-SET-VIEWPORT-POSITION* + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T)) + (WINDOW-MODIFIER-STATE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-SHIFT-VISIBLE-REGION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T)) + (WINDOW-STACK-ON-TOP + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-STREAM-CLASS-NAME #+Cloe-Runtime (CLOE-ROOT-WINDOW) + #+Cloe-Runtime (CLOE-WINDOW-STREAM) + #+Genera (SHEET-WINDOW-STREAM) + #+Minima (CLX-WINDOW)) + (WINDOW-VIEWPORT + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-VIEWPORT-POSITION* + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (WINDOW-VISIBILITY + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + ((SETF WINDOW-VISIBILITY) + (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)) + (INVOKE-WITH-CLIPPING-REGION + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW + T STANDARD-BOUNDING-RECTANGLE)) + (INVOKE-WITH-DRAWING-OPTIONS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T)) + (INVOKE-WITH-OUTPUT-RECORDING-OPTIONS + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T)) + (INVOKE-WITH-TEXT-STYLE + (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T))) + + +;;; (generate-prefill-dispatch-caches 'line-style) + +(PREFILL-DISPATCH-CACHES (LINE-STYLE-CAP-SHAPE (STANDARD-LINE-STYLE)) + (LINE-STYLE-DASHES (STANDARD-LINE-STYLE)) + (LINE-STYLE-JOINT-SHAPE (STANDARD-LINE-STYLE)) + (LINE-STYLE-THICKNESS (STANDARD-LINE-STYLE)) + (LINE-STYLE-UNIT (STANDARD-LINE-STYLE))) + + +;;; (generate-prefill-dispatch-caches 'text-style) + +(PREFILL-DISPATCH-CACHES + (MERGE-TEXT-STYLES (TEXT-STYLE TEXT-STYLE) + (TEXT-STYLE CONS) + (CONS TEXT-STYLE)) + (PARSE-TEXT-STYLE (TEXT-STYLE)) + (TEXT-STYLE-COMPONENTS (TEXT-STYLE)) + (TEXT-STYLE-INDEX (TEXT-STYLE)) + (TEXT-STYLE-MAPPING + (#+Cloe-Runtime CLOE-DEVICE #+Genera SHEET-DEVICE #+Minima CLX-DISPLAY-DEVICE T TEXT-STYLE T))) + + +;;; (generate-prefill-dispatch-caches 'device-font) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches 'fundamental-stream) +;;; Window stuff has been removed by hand since it duplicates earlier entries + +(PREFILL-DISPATCH-CACHES + (ACCEPT-1 (STANDARD-INPUT-EDITING-STREAM T) + (ACCEPT-VALUES-STREAM T)) + (STREAM-CLOSE-TEXT-OUTPUT-RECORD (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + (DECODE-STREAM-FOR-WRITING (STANDARD-INPUT-EDITING-STREAM)) + (DO-INPUT-BUFFER-SCREEN-REAL-ESTATE (STANDARD-INPUT-EDITING-STREAM T)) + (ERASE-INPUT-BUFFER (STANDARD-INPUT-EDITING-STREAM)) + (EXTENDED-OUTPUT-STREAM-P (ACCEPT-VALUES-STREAM)) + (FIND-OR-ADD-QUERY (ACCEPT-VALUES-STREAM T T T T T)) + (INVOKE-FORMATTING-CELL (ACCEPT-VALUES-STREAM T) + (STANDARD-INPUT-EDITING-STREAM T)) + (INITIALIZE-INPUT-EDITING-STREAM (STANDARD-INPUT-EDITING-STREAM)) + (INITIALIZE-POSITION (STANDARD-INPUT-EDITING-STREAM)) + (INPUT-BUFFER-INPUT-POSITION->CURSOR-POSITION* (STANDARD-INPUT-EDITING-STREAM)) + (INPUT-EDITOR-BUFFER (STANDARD-INPUT-EDITING-STREAM)) + (INPUT-POSITION (STANDARD-INPUT-EDITING-STREAM)) + ((SETF INPUT-POSITION) (T STANDARD-INPUT-EDITING-STREAM)) + (INSERTION-POINTER (STANDARD-INPUT-EDITING-STREAM)) + ((SETF INSERTION-POINTER) (T STANDARD-INPUT-EDITING-STREAM)) + (INPUT-EDITING-STREAM-P (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-PROCESS-GESTURE (STANDARD-INPUT-EDITING-STREAM T T)) + #+Genera (CLOS-INTERNALS:OPERATION-HANDLED-P (STANDARD-INPUT-EDITING-STREAM T) + (ACCEPT-VALUES-STREAM T)) + ((SETF ORIGINAL-STREAM-RECORDING-P) (T STANDARD-INPUT-EDITING-STREAM)) + (STREAM-CURRENT-OUTPUT-RECORD (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + ((SETF STREAM-CURRENT-OUTPUT-RECORD) (T STANDARD-INPUT-EDITING-STREAM) + (T ACCEPT-VALUES-STREAM)) + (STREAM-OUTPUT-HISTORY (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + (STREAM-OUTPUT-HISTORY-POSITION (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + (STREAM-CURRENT-REDISPLAY-RECORD (ACCEPT-VALUES-STREAM)) + ((SETF STREAM-CURRENT-REDISPLAY-RECORD) (T ACCEPT-VALUES-STREAM)) + (STREAM-REPLAY (ACCEPT-VALUES-STREAM) + (STANDARD-INPUT-EDITING-STREAM)) + (PRESENTATION-REPLACE-INPUT (STANDARD-INPUT-EDITING-STREAM T T)) + (PROMPT-FOR-ACCEPT (STANDARD-INPUT-EDITING-STREAM T T) + (ACCEPT-VALUES-STREAM T T)) + (REDRAW-INPUT-BUFFER (STANDARD-INPUT-EDITING-STREAM)) + (REMOVE-ACTIVATION-GESTURE (STANDARD-INPUT-EDITING-STREAM)) + (REPLACE-INPUT (STANDARD-INPUT-EDITING-STREAM T)) + (RESCAN-IF-NECESSARY (STANDARD-INPUT-EDITING-STREAM)) + (RESCANNING-P (STANDARD-INPUT-EDITING-STREAM)) + (RESET-CURSOR-POSITION (STANDARD-INPUT-EDITING-STREAM)) + (RESET-SCAN-POINTER (STANDARD-INPUT-EDITING-STREAM)) + #+Genera (CLOS-INTERNALS::SEND-IF-HANDLES (STANDARD-INPUT-EDITING-STREAM T) + (ACCEPT-VALUES-STREAM T)) + #+Genera (STREAM-COMPATIBLE-OUTPUT-AS-PRESENTATION-1 (STANDARD-INPUT-EDITING-STREAM T T)) + #+Genera (STREAM-COMPATIBLE-READ-CHAR (STANDARD-INPUT-EDITING-STREAM)) + (START-CURSOR-POSITION* (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-DEFAULT-VIEW (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + ((SETF STREAM-DEFAULT-VIEW) (T ACCEPT-VALUES-STREAM)) + (STREAM-DRAWING-P (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-END-OF-LINE-ACTION (ACCEPT-VALUES-STREAM) + (STANDARD-INPUT-EDITING-STREAM)) + ((SETF STREAM-END-OF-LINE-ACTION) (T ACCEPT-VALUES-STREAM) + (T STANDARD-INPUT-EDITING-STREAM)) + (STREAM-END-OF-PAGE-ACTION (ACCEPT-VALUES-STREAM) + (STANDARD-INPUT-EDITING-STREAM)) + ((SETF STREAM-END-OF-PAGE-ACTION) (T ACCEPT-VALUES-STREAM) + (T STANDARD-INPUT-EDITING-STREAM)) + (STREAM-FRESH-LINE (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + (STREAM-READ-CHAR (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-READ-GESTURE (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-RECORDING-P (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + (STREAM-REDISPLAYING-P (STANDARD-INPUT-EDITING-STREAM) + (ACCEPT-VALUES-STREAM)) + ((SETF STREAM-REDISPLAYING-P) (T ACCEPT-VALUES-STREAM)) + (STREAM-SET-CURSOR-POSITION* (ACCEPT-VALUES-STREAM T T) + (STANDARD-INPUT-EDITING-STREAM T T)) + (STREAM-STRING-WIDTH (ACCEPT-VALUES-STREAM T) + (STANDARD-INPUT-EDITING-STREAM T)) + (STREAM-TERPRI (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-UNREAD-GESTURE (STANDARD-INPUT-EDITING-STREAM T)) + (STREAM-VERTICAL-SPACING (ACCEPT-VALUES-STREAM) + (STANDARD-INPUT-EDITING-STREAM)) + (STREAM-WRITE-CHAR (STANDARD-INPUT-EDITING-STREAM T) + (ACCEPT-VALUES-STREAM T)) + (STREAM-WRITE-STRING (STANDARD-INPUT-EDITING-STREAM T) + (ACCEPT-VALUES-STREAM T)) + #+Genera (CLOS-INTERNALS::WHICH-OPERATIONS (STANDARD-INPUT-EDITING-STREAM) (ACCEPT-VALUES-STREAM)) + (WINDOW-BEEP (STANDARD-INPUT-EDITING-STREAM)) + (WINDOW-INSIDE-SIZE (STANDARD-INPUT-EDITING-STREAM)) + (INVOKE-WITH-INPUT-EDITOR-TYPEOUT (STANDARD-INPUT-EDITING-STREAM T)) + (INVOKE-WITH-OUTPUT-RECORDING-OPTIONS (STANDARD-INPUT-EDITING-STREAM T T T) + (ACCEPT-VALUES-STREAM T T T)) + (INVOKE-WITH-TEXT-STYLE (STANDARD-INPUT-EDITING-STREAM T T T) + (ACCEPT-VALUES-STREAM T T T))) + + +;;; (generate-prefill-dispatch-caches 'pointer) + +(PREFILL-DISPATCH-CACHES + #+Genera ((SETF POINTER-BUTTON-STATE) (T POINTER)) + (POINTER-POSITION* (POINTER)) + #+Genera ((SETF POINTER-POSITION-CHANGED) (T POINTER)) + (POINTER-SET-POSITION* (POINTER T T)) + (POINTER-WINDOW (POINTER)) + ((SETF POINTER-WINDOW) (T POINTER)) + #+Genera (POINTER-X-POSITION (POINTER)) + #+Genera (POINTER-Y-POSITION (POINTER)) + (QUERY-POINTER (POINTER))) + + +;;; (generate-prefill-dispatch-caches 'console) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches 'device-event) + +(PREFILL-DISPATCH-CACHES + (EVENT-WINDOW (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT)) + (EVENT-MODIFIER-STATE (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT)) + (POINTER-EVENT-BUTTON (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT)) + (POINTER-EVENT-X (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT)) + (POINTER-EVENT-Y (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT))) + + +;;; (generate-prefill-dispatch-caches 'basic-view) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-METHOD + ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE FORM) T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE OR) T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-DIALOG-VIEW) + ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMMAND-NAME) T T T T TEXTUAL-VIEW)) + (ACCEPT-PRESENT-DEFAULT-METHOD + ((PRESENTATION-TYPE COMPLETION) T T T T TEXTUAL-DIALOG-VIEW T T T T)) + (PRESENT-METHOD + ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-MENU-VIEW) + ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-MENU-VIEW) + ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMMAND-NAME) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMMAND) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE OR) T T T T T TEXTUAL-DIALOG-VIEW) + ((PRESENTATION-TYPE OR) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-DIALOG-VIEW) + ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE NULL) T T T T T TEXTUAL-VIEW))) + + +;;; (generate-prefill-dispatch-caches 'standard-application-frame) + +(PREFILL-DISPATCH-CACHES + (DISPLAY-EXIT-BOXES (ACCEPT-VALUES T)) + (EXECUTE-FRAME-COMMAND (ACCEPT-VALUES T)) + (FRAME-COMMAND-TABLE (DEFAULT-APPLICATION) + (ACCEPT-VALUES)) + (FRAME-DOCUMENT-HIGHLIGHTED-PRESENTATION (ACCEPT-VALUES T T T T T T)) + (FRAME-FIND-INNERMOST-APPLICABLE-PRESENTATION (DEFAULT-APPLICATION T T T T) + (ACCEPT-VALUES T T T T)) + (FRAME-INPUT-CONTEXT-BUTTON-PRESS-HANDLER (DEFAULT-APPLICATION T T) + (ACCEPT-VALUES T T)) + (FRAME-NAME (ACCEPT-VALUES)) + (FRAME-POINTER-DOCUMENTATION-OUTPUT (ACCEPT-VALUES)) + (FRAME-REPLAY (DEFAULT-APPLICATION T) + (ACCEPT-VALUES T)) + (FRAME-TOP-LEVEL-SHEET (ACCEPT-VALUES)) + (INITIALIZE-INSTANCE (DEFAULT-APPLICATION) + (ACCEPT-VALUES)) + (LAYOUT-FRAME-PANES (ACCEPT-VALUES T)) + (RUN-FRAME-TOP-LEVEL (ACCEPT-VALUES)) + (SHARED-INITIALIZE (DEFAULT-APPLICATION T) + (ACCEPT-VALUES T))) + + +;;; (generate-prefill-dispatch-caches 'command-table) + +(PREFILL-DISPATCH-CACHES + (COMMAND-PRESENT-IN-COMMAND-TABLE-P (T STANDARD-COMMAND-TABLE)) + (COMMAND-TABLE-INHERIT-FROM (STANDARD-COMMAND-TABLE)) + (COMMAND-TABLE-NAME (STANDARD-COMMAND-TABLE))) + + +;;; (generate-prefill-dispatch-caches 'noise-string) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches 'display-device) + +(PREFILL-DISPATCH-CACHES + ((SETF TEXT-STYLE-MAPPING) #+Cloe-Runtime (T CLOE-DEVICE T T) + #+Genera (T SHEET-DEVICE T T) + #+Minima (T CLX-DISPLAY-DEVICE T T) + (T POSTSCRIPT-DEVICE T T)) + (DISPLAY-DEVICE-NAME #+Cloe-Runtime (CLOE-DEVICE) + #+Genera (SHEET-DEVICE) + #+Minima (CLX-DISPLAY-DEVICE) + (POSTSCRIPT-DEVICE)) + (STANDARDIZE-TEXT-STYLE #+Cloe-Runtime (CLOE-DEVICE T T) + #+Genera (SHEET-DEVICE T T) + #+Minima (CLX-DISPLAY-DEVICE T T) + (POSTSCRIPT-DEVICE T T)) + (TEXT-STYLE-MAPPING #+Cloe-Runtime (CLOE-DEVICE T TEXT-STYLE) + #+Genera (SHEET-DEVICE T TEXT-STYLE) + #+Minima (CLX-DISPLAY-DEVICE T TEXT-STYLE) + #+Genera (SHEET-DEVICE T CONS)) + (TEXT-STYLE-MAPPING* #+Cloe-Runtime (CLOE-DEVICE T T) + #+Genera (SHEET-DEVICE T T) + #+Minima (CLX-DISPLAY-DEVICE T T))) + + +;;; (generate-prefill-dispatch-caches 'io-buffer) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches 'queue) + +(PREFILL-DISPATCH-CACHES (QUEUE-EMPTY-P (QUEUE)) + (QUEUE-FLUSH (QUEUE)) + (QUEUE-GET (QUEUE)) + (QUEUE-NEXT (QUEUE)) + (QUEUE-PUT (QUEUE T)) + (QUEUE-UNGET (QUEUE T))) + + +;;; (generate-prefill-dispatch-caches 'fundamental-cursor) + +(PREFILL-DISPATCH-CACHES ((SETF CURSOR-STREAM) (T TEXT-CURSOR)) + (CURSOR-VISIBILITY (TEXT-CURSOR)) + ((SETF CURSOR-VISIBILITY) (T TEXT-CURSOR)) + (DRAW-CURSOR (TEXT-CURSOR T)) + (CURSOR-POSITION* (TEXT-CURSOR)) + (CURSOR-SET-POSITION* (TEXT-CURSOR T T))) + + +;;; (generate-prefill-dispatch-caches 'accept-values-query) + +(PREFILL-DISPATCH-CACHES (ACCEPT-VALUES-QUERY-CHANGED-P (ACCEPT-VALUES-QUERY)) + (ACCEPT-VALUES-QUERY-EDIT-VALUE (ACCEPT-VALUES-QUERY T)) + ((SETF ACCEPT-VALUES-QUERY-PRESENTATION) (T ACCEPT-VALUES-QUERY)) + (ACCEPT-VALUES-QUERY-TYPE (ACCEPT-VALUES-QUERY)) + (ACCEPT-VALUES-QUERY-VALUE (ACCEPT-VALUES-QUERY))) + + +;;; (generate-prefill-dispatch-caches 'kill-ring-history) + +(PREFILL-DISPATCH-CACHES + (DISPLAY-HISTORY-CONTENTS (KILL-RING-HISTORY T)) + (DISPLAY-HISTORY-MENU-ELEMENT (KILL-RING-HISTORY T T T)) + (DO-HISTORY-ELEMENTS-1 (KILL-RING-HISTORY T)) + (HISTORY-AND-ELEMENT (KILL-RING-HISTORY T)) + (HISTORY-ELEMENT (KILL-RING-HISTORY T)) + (HISTORY-ELEMENT-VISIBLE-P (KILL-RING-HISTORY T)) + (HISTORY-ELEMENTS-EQUAL (KILL-RING-HISTORY T T)) + (HISTORY-LENGTH (KILL-RING-HISTORY)) + (HISTORY-TOP-ELEMENT (KILL-RING-HISTORY)) + (PRINT-HISTORY-ELEMENT (KILL-RING-HISTORY T T)) + (PUSH-HISTORY-ELEMENT (KILL-RING-HISTORY T))) + + +;;; (generate-prefill-dispatch-caches 'presentation-history) + +(PREFILL-DISPATCH-CACHES + (DISPLAY-HISTORY-CONTENTS (PRESENTATION-HISTORY T)) + (DISPLAY-HISTORY-MENU-ELEMENT (PRESENTATION-HISTORY T T T)) + (DO-HISTORY-ELEMENTS-1 (PRESENTATION-HISTORY T)) + (HISTORY-AND-ELEMENT (PRESENTATION-HISTORY T)) + (HISTORY-ELEMENT (PRESENTATION-HISTORY T)) + (HISTORY-ELEMENT-VISIBLE-P (PRESENTATION-HISTORY T)) + (HISTORY-ELEMENTS-EQUAL (PRESENTATION-HISTORY T T)) + (HISTORY-LENGTH (PRESENTATION-HISTORY)) + (HISTORY-TOP-ELEMENT (PRESENTATION-HISTORY)) + (PRESENTATION-HISTORY-TYPE (PRESENTATION-HISTORY)) + (PRESENTATION-TYPE-FOR-YANKING (PRESENTATION-HISTORY)) + (PRINT-HISTORY-ELEMENT (PRESENTATION-HISTORY T T)) + (PUSH-HISTORY-ELEMENT (PRESENTATION-HISTORY T)) + (UNPARSE-PRESENTATION-HISTORY-ELEMENT (PRESENTATION-HISTORY T))) + + +;;; (generate-prefill-dispatch-caches 'presentation-translator) + +(PREFILL-DISPATCH-CACHES + (PRESENTATION-TRANSLATOR-COMMAND-NAME (PRESENTATION-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-DOCUMENTATION (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-FROM-TYPE (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-FUNCTION (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-GESTURE-NAME (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-MENU (PRESENTATION-TRANSLATOR) (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-NAME (PRESENTATION-TRANSLATOR) (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-POINTER-DOCUMENTATION (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-PRIORITY (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-TESTER (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-TESTER-DEFINITIVE (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-TO-TYPE (PRESENTATION-TRANSLATOR) + (PRESENTATION-TO-COMMAND-TRANSLATOR))) + + +;;; (generate-prefill-dispatch-caches 'presentation-to-command-translator) + +(PREFILL-DISPATCH-CACHES + (PRESENTATION-TRANSLATOR-DOCUMENTATION (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-FROM-TYPE (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-FUNCTION (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-GESTURE-NAME (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-MENU (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-NAME (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-POINTER-DOCUMENTATION (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-PRIORITY (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-TESTER (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-TESTER-DEFINITIVE (PRESENTATION-TO-COMMAND-TRANSLATOR)) + (PRESENTATION-TRANSLATOR-TO-TYPE (PRESENTATION-TO-COMMAND-TRANSLATOR))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command)) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-METHOD ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-DIALOG-VIEW)) + (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE COMMAND) T T T T T)) + (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE COMMAND) T T T T T T)) + (PRESENT-METHOD ((PRESENTATION-TYPE COMMAND) T T T T T TEXTUAL-MENU-VIEW) + ((PRESENTATION-TYPE COMMAND) T T T T T TEXTUAL-VIEW)) + (PRESENTATION-SUBTYPEP-METHOD ((PRESENTATION-TYPE COMMAND) T T)) + (PRESENTATION-TYPE-HISTORY-METHOD ((PRESENTATION-TYPE COMMAND) T T)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND) T T T)) + (PRESENTATION-TYPEP-METHOD ((PRESENTATION-TYPE COMMAND) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-name)) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-METHOD ((PRESENTATION-TYPE COMMAND-NAME) T T T T TEXTUAL-VIEW)) + (PRESENT-METHOD ((PRESENTATION-TYPE COMMAND-NAME) T T T T T TEXTUAL-VIEW)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-NAME) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-arguments)) + +(PREFILL-DISPATCH-CACHES + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-ARGUMENTS) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'keyword-argument-name)) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-or-form)) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T T TEXTUAL-VIEW)) + (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T T T)) + (PRESENTATION-SUBTYPEP-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T)) + (PRESENTATION-TYPE-HISTORY-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T)) + (PRESENTATION-TYPEP-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'expression)) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-METHOD ((PRESENTATION-TYPE FORM) T T T T TEXTUAL-VIEW)) + (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE FORM) T T T T T)) + (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE FORM) T T T T T T) + ((PRESENTATION-TYPE EXPRESSION) T T T T T T)) + (PRESENT-METHOD ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-MENU-VIEW) + ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-MENU-VIEW) + ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-VIEW)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE FORM) T T T) + ((PRESENTATION-TYPE EXPRESSION) T T T))) + + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-menu-element)) + +(PREFILL-DISPATCH-CACHES + (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T T T T)) + (PRESENT-METHOD ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T T T TEXTUAL-VIEW)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'menu-item)) + +(PREFILL-DISPATCH-CACHES + (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE MENU-ITEM) T T T T T T)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE MENU-ITEM) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'completion)) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-PRESENT-DEFAULT-METHOD ((PRESENTATION-TYPE COMPLETION) T T T T TEXTUAL-DIALOG-VIEW T T T T)) + (PRESENT-METHOD ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-VIEW) + ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-MENU-VIEW) + ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-DIALOG-VIEW)) + (PRESENTATION-DEFAULT-PREPROCESSOR-METHOD ((PRESENTATION-TYPE COMPLETION) T T)) + (PRESENTATION-TYPE-HISTORY-METHOD ((PRESENTATION-TYPE COMPLETION) T T)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMPLETION) T T T)) + (PRESENTATION-TYPEP-METHOD ((PRESENTATION-TYPE COMPLETION) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'subset-completion)) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'sequence)) + +(PREFILL-DISPATCH-CACHES) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'sequence-enumerated)) + +(PREFILL-DISPATCH-CACHES + (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE SEQUENCE-ENUMERATED) T T T T T)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE SEQUENCE-ENUMERATED) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'null)) + +(PREFILL-DISPATCH-CACHES + (ACCEPT-METHOD ((PRESENTATION-TYPE NULL) T T T T TEXTUAL-VIEW)) + (PRESENT-METHOD ((PRESENTATION-TYPE NULL) T T T T T TEXTUAL-VIEW)) + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE NULL) T T T))) + + +;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'blank-area)) + +(PREFILL-DISPATCH-CACHES + (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE BLANK-AREA) T T T))) diff --git a/clim/text-style.lisp b/clim/text-style.lisp new file mode 100644 index 00000000..1ec27efc --- /dev/null +++ b/clim/text-style.lisp @@ -0,0 +1,659 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: text-style.lisp,v 1.4 91/03/26 12:49:00 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +;;; To consider: how to merge Genera styles with styles. + +(define-protocol-class text-style ()) + +(defclass standard-text-style (text-style) + ((family :initarg :family :initform nil :reader text-style-family) + (face :initarg :face :initform nil :reader text-style-face) + (size :initarg :size :initform nil :reader text-style-size) + (index :initarg :index :initform nil))) + +(define-constructor make-text-style-1 standard-text-style (family face size index) + :family family :face face :size size :index index) + +(defmethod text-style-components ((style standard-text-style)) + (with-slots (family face size) style + (values family face size))) + +(defmethod fully-merged-text-style-p ((style standard-text-style)) + (with-slots (family face size) style + (and family face size))) + +(defmethod make-load-form ((object standard-text-style)) + (with-slots (family face size) object + `(make-text-style ,family ,face ,size))) + +(defmethod print-object ((style standard-text-style) stream) + (with-slots (family face size) style + (let ((true-face (face-code->face face))) + #+Genera + (when *print-readably* + (format stream "#.(~S ~S)" 'parse-text-style + `'(,family ,true-face ,size)) + (return-from print-object style)) + (macrolet ((do-it () + `(format stream "~S.~S.~S" family true-face size))) + (if *print-escape* + (print-unreadable-object (style stream :type t :identity t) + (do-it)) + (do-it)))))) + +(defclass device-font () + ((display-device :initarg :display-device :reader device-font-display-device) + (font-name :initarg :font-name :reader device-font-name))) + +(defun make-device-font (display-device font-name) + (make-instance 'device-font :display-device display-device :font-name font-name)) + +(defmethod print-object ((df device-font) stream) + (print-unreadable-object (df stream :type t :identity t) + (format stream "~A" (slot-value df 'font-name)))) + +(defconstant maximum-text-style-index 256) ;Why not? That's the Genera maximum + +(defvar *standard-character-set* nil) ;Not really used yet. + +(defvar *null-text-style*) +(defvar *undefined-text-style*) +(defvar *text-style-index-table*) +(defvar *next-text-style-index*) +(defvar *text-style-intern-table*) +(defvar *text-style-merging-cache*) +(defvar *default-text-style*) + +(defun initialize-text-style-tables () + (setf *null-text-style* (make-text-style-1 nil nil nil 0) + *undefined-text-style* (make-text-style-1 (make-symbol "UNDEFINED") nil nil 1) + *next-text-style-index* 2 + *text-style-index-table* + (make-array maximum-text-style-index + :initial-element *undefined-text-style*) + *text-style-intern-table* + (copy-tree `((nil . ((nil . ((nil . ,*null-text-style*))))))) + (aref *text-style-index-table* 0) *null-text-style* + *text-style-merging-cache* + (make-array (* maximum-text-style-index 10) + :element-type `(integer 0 (,maximum-text-style-index)) + :initial-element 0) + *default-text-style* + (make-text-style :fix :roman :normal) + *undefined-text-style* + (make-text-style :stand-in-for-undefined-style :roman :normal)) + *null-text-style*) + +(defmethod parse-text-style ((text-style standard-text-style)) + text-style) + +(defmethod parse-text-style ((text-style device-font)) + text-style) + +(defmethod parse-text-style ((null null)) + *null-text-style*) + +(defmethod parse-text-style ((style list)) + (assert (= (length style) 3) (style) + "A text style is a three element list (face family size), not ~S" + style) + (apply #'make-text-style style)) + + +(defvar *text-style-lock* (make-lock "text style lock")) + +;;; The text-style table is an alist-structured database; the +;;; first key is family, then face, then size. This might or might not +;;; be better than an EQUAL hash table. We can decide later to do this +;;; if we want. +(defun make-text-style (family face size &aux changed-p original-face) + (unless (numberp face) + (setf original-face face + face (face->face-code face))) ;"Intern" the face code. + (loop + (let* ((family-stuff (assoc family *text-style-intern-table*)) + (face-stuff (and family-stuff (assoc face (cdr family-stuff)))) + (size-stuff (and face-stuff (assoc size (cdr face-stuff))))) + (when size-stuff (return-from make-text-style (cdr size-stuff))) + (multiple-value-setq (family face size changed-p original-face) + (validate-text-style-components family face size original-face)) + (unless changed-p + (macrolet ((ensure-stuff (stuff thing from-stuff) + `(unless ,stuff + (setf ,stuff (cons ,thing nil)) + (with-lock-held (*text-style-lock* "Text style lock") + (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil))))))) + (ensure-stuff family-stuff family *text-style-intern-table*) + (ensure-stuff face-stuff face family-stuff) + (ensure-stuff size-stuff size face-stuff)) + (let* ((new-style (make-text-style-1 family face size nil))) + (setf (cdr size-stuff) new-style) + (return-from make-text-style new-style)))))) + +(defmethod text-style-index ((text-style standard-text-style)) + (with-slots (index) text-style + (when index (return-from text-style-index index)) + (let* ((new-index (with-lock-held (*text-style-lock* "Text style lock") + (prog1 *next-text-style-index* + (incf *next-text-style-index*))))) + (when (> new-index maximum-text-style-index) + (error "Too many text style indices; can't assign an index to ~A" + text-style)) + (setf (aref *text-style-index-table* new-index) text-style) + (setf index new-index)))) + +(defvar *valid-text-style-sizes* + '(:tiny :very-small :small :normal :large :very-large :huge)) + +(defun validate-text-style-components (family face size &optional original-face) + (when (consp face) ;This is an error in face->face-code. + (apply #'error face)) + ;;--- Handle point sizes + (unless (or (null size) + (numberp size) + (member size *valid-text-style-sizes*) + (eql size :smaller) + (eql size :larger)) + (error "The size ~S is not valid." size)) + ;; This needs to be fleshed out with error handlers, etc. + (values family face size nil original-face)) + +(defun-inline index->text-style (index) + (aref *text-style-index-table* index)) + +;;; General case +(defmethod merge-text-styles (style1 style2) + (setf style1 (parse-text-style style1) + style2 (parse-text-style style2)) + (index->text-style + (merge-text-style-indices (text-style-index style1) + (text-style-index style2)))) + +;;; Device fonts can't be merged against anything. +(defmethod merge-text-styles ((style1 device-font) style2) + (declare (ignore style2)) + style1) + +(defmethod merge-text-styles (style1 (style2 device-font)) + (declare (ignore style1)) + style2) + +(defun merge-text-style-indices (index1 index2) + (when (zerop index1) (return-from merge-text-style-indices index2)) + (let ((subscript (+ index1 (* index2 maximum-text-style-index)))) + (when (>= subscript (array-total-size *text-style-merging-cache*)) + (let ((new (make-array (* (min (+ index2 5) maximum-text-style-index) + maximum-text-style-index) + :element-type `(integer 0 (,maximum-text-style-index)) + :initial-element 0))) + (replace new *text-style-merging-cache*) + (setq *text-style-merging-cache* new))) + (let ((merged-style-index (aref *text-style-merging-cache* subscript))) + (when (plusp merged-style-index) + (return-from merge-text-style-indices merged-style-index))) + (let ((merged-style-index + (text-style-index + (multiple-value-bind (result-family result-face result-size) + (multiple-value-bind (family1 face1 size1) + (text-style-components (index->text-style index1)) + (multiple-value-bind (family2 face2 size2) + (text-style-components (index->text-style index2)) + (merge-text-style-components family1 face1 size1 + family2 face2 size2))) + (make-text-style result-family result-face result-size))))) + (setf (aref *text-style-merging-cache* subscript) merged-style-index) + merged-style-index))) + +(defun merge-text-style-components (family1 face1 size1 family2 face2 size2) + (values (merge-text-style-families family1 family2) + (merge-text-style-faces face1 face2) + (merge-text-style-sizes size1 size2))) + +(defun merge-text-style-families (family1 family2) + (or family1 family2)) + +(defun merge-text-style-sizes (size1 size2) + (let ((max-larger-size 24) ;limits for :LARGER and :SMALLER + (min-smaller-size 4)) + (case size1 + (:larger + (cond ((numberp size2) (min (+ size2 2) max-larger-size)) + ((eql size2 :smaller) nil) ;let a higher level decide... + (t (let ((index (position size2 *valid-text-style-sizes*))) + (if (null index) + size1 + (or (nth (1+ index) *valid-text-style-sizes*) :huge)))))) + (:smaller + (cond ((numberp size2) (max (- size2 2) min-smaller-size)) + ((eql size2 :larger) nil) ;let a higher level decide... + (t (let ((index (position size2 *valid-text-style-sizes*))) + (if (null index) + size1 + (if (zerop index) :tiny (nth (1- index) *valid-text-style-sizes*))))))) + (otherwise + (or size1 size2))))) + +(defmacro define-text-face-class (class name-list lambda-list &body merging-function + &environment env) + (multiple-value-bind (documentation declarations body) + (extract-declarations merging-function env) + (let ((text-face-class-definitions + (mapcar #'(lambda (name) `(add-text-face-class ',name ',class)) name-list)) + (face-code-mask-macro-name (fintern "~A-~A" class 'face-code-mask)) + (set-bits-macro-name (fintern "~A-~A-~A" 'set class 'face-code-bits)) + (reset-bits-macro-name (fintern "~A-~A-~A" 'reset class 'face-code-bits)) + (test-bits-macro-name (fintern "~A-~A-~A" 'test class 'face-code-bits))) + `(define-group ,class define-text-face-class + (define-text-face-class-load-time ',class) + + ;; Cloe doesn't appear able to find the MACROLETted versions below. + #+Cloe-Runtime ;Cloe bug? + (progn + (defmacro ,face-code-mask-macro-name (&rest face-codes) + (let ((result 0)) + (dolist (face-code face-codes result) + (assert (member face-code ',name-list)) + (setf result (logior result + (ash 1 (position face-code ',name-list))))))) + (defmacro ,test-bits-macro-name (datum &rest face-codes) + `(logtest ,datum (,',face-code-mask-macro-name ,@face-codes))) + (defmacro ,set-bits-macro-name (datum &rest face-codes) + `(setf ,datum + (logior ,datum (,',face-code-mask-macro-name ,@face-codes)))) + (defmacro ,reset-bits-macro-name (datum &rest face-codes) + `(setf ,datum + (logand ,datum + (lognot (,',face-code-mask-macro-name ,@face-codes)))))) + (defun-property (:property ,class face-class-merging-function) ,lambda-list + ,@declarations + ,@(when documentation (list documentation)) + (macrolet ((,face-code-mask-macro-name (&rest face-codes) + (let ((result 0)) + (dolist (face-code face-codes result) + (assert (member face-code ',name-list)) + (setf result (logior result + (ash 1 (position face-code ',name-list))))))) + (,test-bits-macro-name (datum &rest face-codes) + `(logtest ,datum (,',face-code-mask-macro-name ,@face-codes))) + (,set-bits-macro-name (datum &rest face-codes) + `(setf ,datum + (logior ,datum (,',face-code-mask-macro-name ,@face-codes)))) + (,reset-bits-macro-name (datum &rest face-codes) + `(setf ,datum + (logand ,datum + (lognot (,',face-code-mask-macro-name ,@face-codes)))))) + ,@body)) + ,@text-face-class-definitions)))) + +(defmacro define-text-face-added-mappings (class &body mappings) + `(add-face-added-text-mappings ',class ',mappings)) + +(defvar *face->face-code-cache* nil) +(defvar *face-added-text-mapping-cache* nil) + +(defun define-text-face-class-load-time (class) + (let ((alist (assoc class *face->face-code-cache*))) + (when (null alist) + (setf alist (cons class nil)) + (setf *face->face-code-cache* (nconc *face->face-code-cache* (list alist)))))) + +(defmacro define-text-face (name class) + `(add-text-face-class ',name ',class)) + +(defun add-text-face-class (name class) + (let ((alist (assoc class *face->face-code-cache*))) + (when (null alist) + (error "Can't define face ~S in unknown face class ~S." name class)) + (unless (member name (cdr alist)) + (nconc alist (list name))))) + +(defun add-face-added-text-mappings (class mappings) + (let ((pair (assoc class *face-added-text-mapping-cache*))) + (unless pair + (setf pair (list class)) + (push pair *face-added-text-mapping-cache*)) + (dorest (mapping-pair mappings cddr) + (let* ((logical (first mapping-pair)) + (underlying (face->face-code (second mapping-pair))) + (mapping-pair (assoc logical (cdr pair)))) + (if mapping-pair + (setf (cdr mapping-pair) underlying) + (push (cons logical underlying) (cdr pair))))))) + +(defconstant %%face-code-no-merge (byte 1 28)) +(defconstant %%face-code-class (byte 4 24)) +(defconstant %%face-code-faces (byte 24 0)) + +(defun face->face-code (face) + (when (null face) (return-from face->face-code nil)) + (let ((class-alist nil) + (added-mapping-alist nil) + (class-number nil) + (value 0) + (no-merge 0)) + (flet ((parse-face (face) + (when (eql face :no-merge) + (setf no-merge 1) + (return-from parse-face 0)) + (if class-number + (or + (cdr (assoc face (cdr added-mapping-alist))) + (ash 1 + (or (position face (cdr class-alist)) + (return-from face->face-code ;Return an error indication. + (list "Can't parse face ~S in class ~S" + face (car class-alist)))))) + (do ((face-cache *face->face-code-cache* (cdr face-cache)) + (class-no 0 (1+ class-no))) + ((null face-cache) + (return-from face->face-code (list "Can't parse face ~S" face))) + (let ((value (position face (cdar face-cache)))) + (when value + (setf class-number class-no + class-alist (car face-cache) + added-mapping-alist (assoc (car class-alist) + *face-added-text-mapping-cache*)) + (return (ash 1 value)))) + (let* ((added-value-mapping-alist + (assoc (caar face-cache) *face-added-text-mapping-cache*)) + (value (cdr (assoc face (cdr added-value-mapping-alist))))) + (when value + (setf class-number class-no + class-alist (car face-cache) + added-mapping-alist added-value-mapping-alist) + (return value))))))) + (if (listp face) + (dolist (face face) + (setf value (logior value (parse-face face)))) + (setf value (parse-face face)))) + (dpb class-number %%face-code-class + (dpb value %%face-code-faces + (dpb no-merge %%face-code-no-merge 0))))) + +(defvar *face-code->face-cache* (make-hash-table)) + +(defun face-code->face (face-code) + (when (or (null face-code) (zerop face-code)) ;?? zerop? + (return-from face-code->face nil)) + (or (gethash face-code *face-code->face-cache*) + (let* ((class-number (ldb %%face-code-class face-code)) + (face-bits (ldb %%face-code-faces face-code)) + (class-alist (cdr (nth class-number *face->face-code-cache*))) + (result (if (ldb-test %%face-code-no-merge face-code) + (list :no-merge) + (= (logcount face-bits) 1)))) + (loop + (when (zerop face-bits) + (return (setf (gethash face-code *face-code->face-cache*) (nreverse result)))) + (when (logtest face-bits 1) + (when (eql result t) (return (car class-alist))) + (push (car class-alist) result)) + (pop class-alist) + (setf face-bits (ash face-bits -1)))))) + +(defun merge-text-style-faces (face1 face2) + (when (null face1) (return-from merge-text-style-faces face2)) + (when (null face2) (return-from merge-text-style-faces face1)) + (let ((class1 (ldb %%face-code-class face1))) + (unless (= class1 (ldb %%face-code-class face2)) + (return-from merge-text-style-faces face1)) + (funcall (get (car (nth class1 *face->face-code-cache*)) 'face-class-merging-function) + face1 face2))) + +(define-text-face-class :roman (:roman :extra :bold :italic :condensed :extended + :caps :underline :outline :shadow) + (face1 face2) + (let ((result (logior face1 face2))) + (when (ldb-test %%face-code-no-merge face1) + (setf result (dpb 0 %%face-code-no-merge face1))) + ;; Some heuristics: when condensed, we're not extended and vice-versa + (when (test-roman-face-code-bits face1 :condensed) + (reset-roman-face-code-bits result :extended)) + (when (test-roman-face-code-bits face1 :extended) + (reset-roman-face-code-bits result :condensed)) + ;; And a couple more: when roman, we're not bold or italic, and vice-versa + (when (test-roman-face-code-bits face1 :roman) + (reset-roman-face-code-bits result :bold :italic :extra)) + (when (test-roman-face-code-bits face1 :bold :italic) + (reset-roman-face-code-bits result :roman)) + result)) + +(define-text-face-added-mappings :roman + :bold-italic (:bold :italic) + :bold-condensed-caps (:bold :condensed :caps) + :bold-extended (:bold :extended) + :extra-condensed (:extra :condensed)) + +(define-text-face-class :special (:uppercase) + (face1 face2) + (or face1 face2)) + +(define-text-face-class :logical () + (face1 face2) + (declare (ignore face2)) + face1) + +(when (not (boundp '*null-text-style*)) + (initialize-text-style-tables)) + + +(defgeneric text-style-height (text-style medium)) +(defgeneric text-style-width (text-style medium)) +(defgeneric text-style-ascent (text-style medium)) +(defgeneric text-style-descent (text-style medium)) +(defgeneric text-style-fixed-width-p (text-style medium)) + +(defgeneric text-size (medium string &key text-style start end) + (declare (values width height final-x final-y baseline))) + + +(defmethod text-style-height ((text-style standard-text-style) + (stream standard-encapsulating-stream)) + (text-style-height text-style (slot-value stream 'stream))) + +(defmethod text-style-width ((text-style standard-text-style) + (stream standard-encapsulating-stream)) + (text-style-width text-style (slot-value stream 'stream))) + +(defmethod text-style-ascent ((text-style standard-text-style) + (stream standard-encapsulating-stream)) + (text-style-ascent text-style (slot-value stream 'stream))) + +(defmethod text-style-descent ((text-style standard-text-style) + (stream standard-encapsulating-stream)) + (text-style-descent text-style (slot-value stream 'stream))) + +(defmethod text-style-fixed-width-p ((text-style standard-text-style) + (stream standard-encapsulating-stream)) + (text-style-fixed-width-p text-style (slot-value stream 'stream))) + +(defmethod text-size ((stream standard-encapsulating-stream) string + &key (text-style (stream-merged-text-style stream)) (start 0) end) + (text-size stream string :text-style text-style :start start :end end)) + + +#-Genera +(defun merged-text-style (character style) + (values character style)) + +#+Genera +(progn + +(defvar *genera-style-to-style-table* (make-array 256 :initial-element nil)) + +(defun genera-style->style (character-style) + (let ((index (si:style-index character-style))) + (or (aref *genera-style-to-style-table* index) + (setf (aref *genera-style-to-style-table* index) + (parse-text-style (si:unparse-character-style character-style)))))) + +(defun merged-text-style (character style) + (let* ((char-style (si:char-style character)) + (char-style (genera-style->style char-style)) + (merged-style (merge-text-styles style char-style))) + (values (sys:make-character character :style nil) merged-style))) +) ;;; End of #+Genera + + +;; See SHEET-GRAPHICS-IMPLEMENTATION for an example of its use... +(defmacro define-display-device (name class &key font-for-undefined-style) + `(defvar ,name (make-instance ',class + :name ',name + :font-for-undefined-style ',font-for-undefined-style))) + +;;; [ 1/4/90 naha -- determined by reading DEFINE-TEXT-STYLE-MAPPINGS-LOAD-TIME ] +;;; each element of SPECS can be one of +;;; `(:style ,family ,face ,size) [what will this do?] +;;; `(:family ,family ,specs) ==> recurse on specs for specified family +;;; `(:face ,face ,specs) ==> recurse on specs for specified face +;;; `(:size ,size ,specs) ==> recurse on specs for specified size +;;; the name of a font to map the specified text style to. + +(defmacro define-text-style-mappings (device character-set &body specs) + `(define-text-style-mappings-load-time ,device ,character-set ',specs)) + +(defun define-text-style-mappings-load-time (device character-set specs) + (labels ((load-specs (family face size specs) + (when (and (consp specs) (eql (first specs) :style)) + (setf specs (apply #'make-text-style (rest specs)))) + (if (and (consp specs) (not (eql (car specs) :style))) + (do* ((type (first specs)) + (my-specs (cdr specs) (cddr my-specs)) + (value (first my-specs) (first my-specs)) + (rest (second my-specs) (second my-specs))) + ((null my-specs)) + (case type + (:family (setf family value)) + (:face (setf face value)) + (:size (setf size value)) + (otherwise (warn "Ill-formed mapping contains ~S" specs))) + (load-specs family face size rest)) + (if (and family face size) + (setf (text-style-mapping + device character-set (make-text-style family face size)) + specs) + (error "Can't do [~A.~A.~A]" family face size))))) + (dolist (spec specs) + (load-specs nil nil nil spec)))) + +(defclass display-device () + ((name :initarg :name :reader display-device-name) + (mapping-table :initform (make-hash-table)))) + +(defvar *display-devices* nil) + +(defmethod initialize-instance :after + ((device display-device) &key font-for-undefined-style) + ;; Keep track of all of the display devices + (push-unique device *display-devices* :key #'display-device-name) + (when font-for-undefined-style + (setf (text-style-mapping + device *standard-character-set* *undefined-text-style*) + font-for-undefined-style))) + +(defmethod print-object ((device display-device) stream) + (print-unreadable-object (device stream :type t :identity t) + (format stream "~A" (slot-value device 'name)))) + +(defmethod (setf text-style-mapping) + (mapping (device display-device) character-set style &optional window) + (declare (ignore window)) + (setq style (standardize-text-style device character-set style)) + (when (listp mapping) + (assert (eql (first mapping) :style) () + "Text style mappings must be atomic font names ~ + or (:STYLE . (family face size))") + (setf mapping (parse-text-style (cdr mapping)))) + (setf (gethash style (slot-value device 'mapping-table)) mapping)) + +#+CLIM-1-compatibility +(define-compatibility-function (add-text-style-mapping (setf text-style-mapping)) + (device character-set style mapping) + (setf (text-style-mapping device character-set style) mapping)) + +;;; This is broken up into two methods so any :AROUND method will only +;;; be called on the outermost recursion. +(defmethod text-style-mapping + ((device display-device) character-set style &optional window) + (text-style-mapping* device character-set style window)) + +(defmethod text-style-mapping + ((device display-device) character-set (style device-font) &optional window) + (declare (ignore character-set window)) + ;;--- What about character-set when using device fonts? + ;;--- EQL? TYPE-EQUAL? This is too restrictive as it stands + (unless (eql device (device-font-display-device style)) + (error "An attempt was made to map device font ~S on device ~S, ~@ + but it is defined for device ~S" + style device (device-font-display-device style))) + (device-font-name style)) + +(defmethod text-style-mapping* ((device display-device) character-set style &optional window) + (setq style (standardize-text-style device character-set (parse-text-style style))) + (let* ((mapping-table (slot-value device 'mapping-table)) + (result (or (gethash style mapping-table) + (gethash *undefined-text-style* mapping-table)))) + (when (text-style-p result) ;logical translations + (setf result (text-style-mapping* device character-set result window))) + result)) + +(defmethod text-style-mapping-exists-p ((device display-device) character-set style) + (setq style (standardize-text-style device character-set (parse-text-style style))) + (let* ((mapping-table (slot-value device 'mapping-table)) + (result (gethash style mapping-table))) + (cond ((null result) nil) + ((text-style-p result) ;logical translations + (text-style-mapping-exists-p device character-set style)) + (t t)))) + +;; This method allows the device to convert logical sizes into point +;; sizes, etc. The default method doesn't do much of anything. +(defmethod standardize-text-style ((device display-device) character-set style) + (declare (ignore character-set)) + (unless (numberp (text-style-size style)) + (standardize-text-style-error style)) + style) + +(defun standardize-text-style-error (style) + (if (fully-merged-text-style-p style) + (cerror "Use the undefined text style stand-in instead" + "The size component of ~S is not numeric. This display-device does not know ~ + how to map logical text style sizes" + style) + (cerror "Use the undefined text style stand-in instead" + "The text style ~S must be a fully merged text style" + style)) + *undefined-text-style*) + +;; For use by more specific STANDARDIZE-TEXT-STYLE methods +(defun-inline standardize-text-style-1 (display-device style character-set size-alist) + (declare (ignore display-device character-set)) + (let ((size (text-style-size style))) + (if (numberp size) + style + (let ((new-size (assoc size size-alist))) + (cond (new-size + (make-text-style (text-style-family style) + (text-style-face style) + (second new-size))) + (t + (standardize-text-style-error style))))))) + + +;;; Extensions to Common Lisp character operations. + +(defun-inline diacritic-char-p (character) + #-Genera (declare (ignore character)) + #+Genera (si:diacritic-char-p character) + #-Genera nil) + +;;; For now, only standard character set characters are understood... +(defun-inline char-character-set-and-index (character) + (declare (values character-set index)) + (values *standard-character-set* (char-code character))) diff --git a/demo/browser.lisp b/demo/browser.lisp new file mode 100644 index 00000000..f23307cf --- /dev/null +++ b/demo/browser.lisp @@ -0,0 +1,1383 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Package: (CLIM-BROWSER :use (CLIM-LISP CLIM)); Base: 10; Lowercase: Yes -*- + +;;; Simple extensible browser +;;; Scott McKay + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; To use the Browser, first choose a browser type and browser subtype from +;;; the ACCEPTING-VALUES pane in the lower right corner. +;;; +;;; After you have selected a browser type, use the "Show Graph" command to +;;; specify the root node for the graph. You can supply more than one root. +;;; The type of the object you supply to "Show Graph" varies with what the +;;; browser type is (for example, when browsing classes you should type in +;;; a class name.) +;;; +;;; Once there is a graph drawn, there are a number of useful mouse gestures +;;; defined for the nodes in the graph: +;;; +;;; +;;; +;;; +;;; inferiors, and replaces them with an ellipsis node (indicated by "..."). +;;; +;;; +;;; +;;; create some sort of "subnode" which contains additional information (for +;;; example, the slots for a class). +;;; +;;; of operations specific to the browser type (for example, when browsing +;;; classes you might get other class-related commands). +;;; +;;; There are some other options in the ACCEPTING-VALUES pane: +;;; +;;; +;;; should be shared or not. +;;; +;;; There are also a few command buttons: +;;; +;;; +;;; +;;; +;;; +;;; +;;; The items it displays are mouse-sensitive. +;;; +;;; +;;; There are a few additional commands: +;;; +;;; are currently two modes, graphical and textual. +;;; +;;; It is pretty obvious how to write your own browser extensions. Enjoy. + +;;--- This presumes that both SAP:>swm>clim>code>draw-arrow.lisp is loaded + + +;;; Utilities + +(defparameter *browser-print-length* 2) +(defparameter *browser-print-level* 2) + +(defun false (&rest args) + (declare (ignore args)) + nil) + +(defun true (&rest args) + (declare (ignore args)) + t) + +(defmacro with-browser-io-environment (&body body) + `(invoke-with-browser-io-environment #'(lambda () ,@body))) + +(defun invoke-with-browser-io-environment (continuation) + (declare (dynamic-extent continuation)) + ;; Heavily truncate the printed result + (let ((*print-base* 10) + (*print-radix* nil) + (*print-readably* nil) + (*print-pretty* nil) + (*print-length* *browser-print-length*) + (*print-level* *browser-print-level*) + (*print-circle* nil) + (*print-array* nil) + (*print-escape* t) + #+Genera (scl:*print-string-length* nil) + #+Genera (scl:*print-structure-contents* nil)) + (funcall continuation))) + +(defmacro centering-line ((&optional stream) &body body) + `(invoke-centering-line #'(lambda (,stream) ,@body) ,stream)) + +(defun invoke-centering-line (continuation stream) + (multiple-value-bind (sx sy) (stream-cursor-position* stream) + (let ((inside-width (window-inside-width stream)) + (line-width (bounding-rectangle-width + (with-output-to-output-record (stream) + (funcall continuation stream))))) + (stream-set-cursor-position* stream (+ sx (floor (- inside-width line-width) 2)) sy) + (funcall continuation stream)))) + + +;;; Basic call nodes + +;; These are the generic functions that are intended to be specialized +(defgeneric node-object-name (call-node)) +(defgeneric display-node (call-node stream)) +(defgeneric node-generate-inferior-objects (call-node subtype)) +(defgeneric node-any-inferior-objects-p (call-node subtype)) +(defgeneric node-arc-drawer (call-node) + #+Genera (declare (values arc-drawer arc-drawing-options))) + + +(defclass basic-call-node () + ((object :reader node-object :initarg :object) + (inferiors :accessor node-inferiors :initform nil) + (superiors :accessor node-superiors :initform nil) + ;; RECURSES is T iff this node eventually calls itself + (recurses :accessor node-recurses :initform nil) + (tick :accessor node-tick :initform 0))) + +(defmethod node-object-name ((node basic-call-node)) + (node-object node)) + +(defmethod print-object ((node basic-call-node) stream) + (with-browser-io-environment + (if *print-escape* + (print-unreadable-object (node stream :type t :identity t) + (write (node-object-name node) :stream stream :escape nil)) + (write (node-object-name node) :stream stream :escape nil)))) + +;; Propagate ticks up the graph to get proper redisplay. +(defmethod tick-node ((node basic-call-node)) + (labels ((tick (node) + (incf (node-tick node)) + ;; No need to check for recursion since it is the responsibility + ;; of the graph generator to do that. + (dolist (superior (node-superiors node)) + (tick superior)))) + (declare (dynamic-extent #'tick)) + (tick node))) + +(defparameter *display-node-character-style* '(:sans-serif nil :very-small)) +(defmethod display-node :around ((node basic-call-node) stream) + (updating-output (stream :unique-id node + :cache-value (node-tick node)) + (with-text-style (stream *display-node-character-style*) + (call-next-method node stream)))) + +(defmethod display-node ((node basic-call-node) stream) + (with-output-as-presentation (stream node (presentation-type-of node)) + (write (node-object node) :stream stream :escape nil))) + +;; Let the "to" node contribute to the drawing of the arc to it. +(defmethod node-arc-drawer ((node basic-call-node)) + (values #'draw-arrow* nil)) + +(defmethod node-generate-inferior-objects ((node basic-call-node) subtype) + (declare (ignore subtype)) + nil) + +;; Answers the question "will NODE-GENERATE-INFERIOR-OBJECTS return anything?", +;; except that it's allowed to be much faster. If this returns T, that means +;; NODE-GENERATE-INFERIOR-OBJECTS might return something; if this returns NIL, +;; then NODE-GENERATE-INFERIOR-OBJECTS will definitely not return anything. +(defmethod node-any-inferior-objects-p ((node basic-call-node) subtype) + (declare (ignore subtype)) + t) + +(defun node-eql (n1 n2) + (eql (node-object n1) (node-object n2))) + + +;; This is the most basic instantiable sort of call node. +;; Commands and translators are written on this, not on BASIC-CALL-NODE. +(defclass call-node (basic-call-node) ()) + +;; CALL-SUBNODEs are a stripped-down version of CALL-NODEs, which mostly +;; means that most commands and translators don't operate on subnodes. +(defclass call-subnode (basic-call-node) ()) + +(defmethod node-any-inferior-objects-p ((node call-subnode) type) + (declare (ignore type)) + nil) + +(defmethod node-arc-drawer ((node call-subnode)) + (values #'draw-arrow* '(:line-dashes #(2 2)))) + + +;; Ellipsis nodes +(defclass ellipsis-call-node + (basic-call-node) + ((replaced-node :reader ellipsis-node-replaced-node :initarg :replaced-node))) + +(proclaim '(inline make-ellipsis-call-node)) +(defun make-ellipsis-call-node (object replaced-node) + (make-instance 'ellipsis-call-node :object object :replaced-node replaced-node)) + +(defmethod initialize-instance :after ((node ellipsis-call-node) &rest init-options) + (declare (ignore init-options)) + ;; The inferiors of the ellipsis node are all of the combined inferiors + ;; of the node we are replacing + (let ((inferiors nil)) + (dolist (inferior (node-inferiors (ellipsis-node-replaced-node node))) + (setq inferiors (nconc inferiors (copy-list (node-inferiors inferior))))) + (setf (node-inferiors node) inferiors)) + node) + +(defmethod display-node ((node ellipsis-call-node) stream) + (with-output-as-presentation (stream node 'ellipsis-call-node) + (write-string "..." stream))) + + +;;; Hooks to define a type of browser + +(defvar *browser-types* nil) + +(defgeneric browser-type-subtypes (type)) +(defgeneric browser-type-information (type subtype) + #+Genera (declare (values node-maker root-node-maker + graph-type grapher-args presentation-type options))) + +(defmacro define-browser-type (type presentation-type graph-type options &body subtypes) + #+Genera (declare (zwei:indentation 3 3 4 1)) + (let ((subtype-names (mapcar #'first subtypes))) + `(progn + (let ((old (member ',type *browser-types*))) + (if old + (setf (car old) ',type) + (setq *browser-types* (nconc *browser-types* (list ',type))))) + (defmethod browser-type-subtypes ((type (eql ',type))) + ',subtype-names) + ,@(mapcar + #'(lambda (entry) + (destructuring-bind (subtype node-maker root-node-maker grapher-args) entry + `(defmethod browser-type-information ((type (eql ',type)) + (subtype (eql ',subtype))) + (values ',node-maker ',root-node-maker + ',graph-type ',grapher-args + ',presentation-type ',options)))) + subtypes)))) + + +;;; Function call browsing + +(defclass function-call-node (call-node) ()) + +(proclaim '(inline make-function-call-node)) +(defun make-function-call-node (object) + (make-instance 'function-call-node :object object)) + +(defmethod node-object-name ((node function-call-node)) + (let ((function (node-object node))) + #+Genera (if (functionp function) (sys:function-name function) function) + #-Genera function)) + +(defmethod display-node ((node function-call-node) stream) + (labels ((draw (stream) + (with-output-as-presentation (stream node 'function-call-node) + (present (node-object-name node) 'expression :stream stream)))) + (declare (dynamic-extent #'draw)) + (if (node-recurses node) + (surrounding-output-with-border (stream :shape :rectangle) + (draw stream)) + (draw stream)))) + +(define-browser-type :function expression :graphical + () + (:callees make-function-call-node function-browser-make-root + (:arc-drawer draw-arrow*)) + (:callers make-function-call-node function-browser-make-root + (:arc-drawer draw-arrow* :arc-drawing-options (:from-head t :to-head nil)))) + +(defun function-browser-make-root (object) + (typecase object + (function + (make-function-call-node object)) + (symbol + (when (fboundp object) + (make-function-call-node (fdefinition object)))))) + +#+Genera +(defmethod node-generate-inferior-objects ((node function-call-node) (type (eql ':callees))) + (let ((function (node-object node))) + (typecase function + (compiled-function + (let ((callees nil)) + (si:map-over-compiled-function-callees + function + #'(lambda (caller callee how) + (declare (ignore caller)) + (case how + ((:function :generic-function) + (pushnew (sys:fdefinition callee) callees)) + (:variable + (pushnew callee callees)))) + :external-references t) + (nreverse callees))) + (flavor:generic-function + ;; Return all the real methods for this generic function + (loop for method in (sort (flavor:generic-function-methods + (sys:generic-function-name function)) + #'string-lessp + :key #'flavor:method-flavor) + as function = (unless (and (listp method) + (eql (first method) 'flavor:read-instance-variable)) + (si:valid-function-definition method)) + when function + collect function)) + (clos:generic-function + ;; Return all the real methods for this generic function + (loop for method in (clos-internals::sort-generic-function-methods + function + (copy-list (clos:generic-function-methods function)) + :sort :heuristic) + as function = (clos:method-function method) + when function + collect function))))) + +#+Genera +(defmethod node-generate-inferior-objects ((node function-call-node) (type (eql ':callers))) + (let ((function (node-object node))) + (let ((callee-function-name (sys:function-name function))) + (typecase callee-function-name + (clos:method + (list (clos:method-generic-function callee-function-name))) + (t + (if (and (listp callee-function-name) + (eql (car callee-function-name) 'flavor:method)) + (list (flavor:method-generic callee-function-name)) + (let ((callers nil)) + (si:map-over-callers + (sys:function-name function) + #'(lambda (caller how) + (case how + ((:function :generic-function :macro) + (pushnew (sys:fdefinition caller) callers)) + (:variable + (pushnew caller callers)))) + :called-how '(:function :generic-function :macro :variable)) + (nreverse callers)))))))) + + +;;; CLOS class browsing + +(define-presentation-type class () + :history t) + +#+Genera +(define-presentation-method accept ((type class) stream (view textual-view) &key) + (find-class + (completing-from-suggestions (stream :partial-completers '(#\-)) + (map nil #'(lambda (x) + (if (listp x) + (suggest (first x) (second x)) + (suggest (symbol-name x) x))) + clos-internals:*all-class-names-aarray*)))) + +#-Genera +(define-presentation-method accept ((type class) stream (view textual-view) &key default) + (let* ((class-name (accept 'symbol :stream stream :view view + :default (and default (class-name default)) + :prompt nil)) + (class (find-class class-name nil))) + (unless class + (input-not-of-required-type class-name type)) + class)) + +(define-presentation-method present (class (type class) stream (view textual-view) &key) + (prin1 (class-name class) stream)) + + +(defclass class-call-node (call-node) ()) + +(proclaim '(inline make-class-call-node)) +(defun make-class-call-node (object) + (make-instance 'class-call-node :object object)) + +(defmethod node-object-name ((node class-call-node)) + (class-name (node-object node))) + +(defmethod display-node ((node class-call-node) stream) + (let ((class (node-object node))) + (with-output-as-presentation (stream node 'class-call-node) + (with-output-as-presentation (stream class 'class) + (write (node-object-name node) :stream stream))))) + +(define-browser-type :class class :graphical + () + (:superclasses make-class-call-node clos-browser-make-root + (:arc-drawer draw-arrow* :arc-drawing-options (:from-head t :to-head nil))) + (:subclasses make-class-call-node clos-browser-make-root + (:arc-drawer draw-arrow*))) + +(defun clos-browser-make-root (object) + (typecase object + (class + (make-class-call-node object)) + (symbol + (let ((class (find-class object nil))) + (when class + (make-class-call-node class)))))) + +(defmethod node-generate-inferior-objects ((node class-call-node) (type (eql ':superclasses))) + (class-direct-superclasses (node-object node))) + +(defmethod node-any-inferior-objects-p ((node class-call-node) (type (eql ':superclasses))) + (not (null (class-direct-superclasses (node-object node))))) + +(defmethod node-generate-inferior-objects ((node class-call-node) (type (eql ':subclasses))) + (class-direct-subclasses (node-object node))) + +(defmethod node-any-inferior-objects-p ((node class-call-node) (type (eql ':subclasses))) + (not (null (class-direct-subclasses (node-object node))))) + + +(defclass clos-slot-call-subnode (call-subnode) ()) + +(proclaim '(inline make-clos-slot-call-subnode)) +(defun make-clos-slot-call-subnode (class-node slots) + (let ((subnode (make-instance 'clos-slot-call-subnode :object slots))) + (setf (node-superiors subnode) (list class-node)) + subnode)) + +(defmethod node-object-name ((node clos-slot-call-subnode)) + (format nil "Slots of ~S" (node-object-name (first (node-superiors node))))) + +(defmethod display-node ((node clos-slot-call-subnode) stream) + (let ((slots (node-object node))) + (with-output-as-presentation (stream node 'clos-slot-call-subnode + :single-box t) + (surrounding-output-with-border (stream :shape :rectangle) + (formatting-table (stream) + (dolist (slot slots) + (formatting-row (stream) + (formatting-cell (stream) + (present slot 'symbol :stream stream))))))))) + + +(defclass clos-method-call-subnode (call-subnode) ()) + +(proclaim '(inline make-clos-method-call-subnode)) +(defun make-clos-method-call-subnode (class-node method-list) + (let ((subnode (make-instance 'clos-slot-call-subnode :object method-list))) + (setf (node-superiors subnode) (list class-node)) + subnode)) + +(defmethod node-object-name ((node clos-method-call-subnode)) + (format nil "Methods of ~S" (node-object-name (first (node-superiors node))))) + +(defmethod display-node ((node clos-method-call-subnode) stream) + (let ((methods (node-object node))) + (with-output-as-presentation (stream node 'clos-method-call-subnode + :single-box t) + (surrounding-output-with-border (stream :shape :rectangle) + (formatting-table (stream) + (dolist (item methods) + (formatting-row (stream) + (formatting-cell (stream) + (destructuring-bind (gf method) item + (with-output-as-presentation (stream method 'expression + :allow-sensitive-inferiors nil) + (prin1 (clos:generic-function-name gf) stream))))))))))) + + +;;; Package browsing + +(define-presentation-type package () + :inherit-from t + :history t) + +#+Genera +(define-presentation-method accept ((type package) stream (view textual-view) &key) + (completing-from-suggestions (stream :partial-completers '(#\-)) + (map nil #'(lambda (package) + (suggest (package-name package) package)) + (list-all-packages)))) + +(define-presentation-method present (package (type package) stream (view textual-view) &key) + (princ (package-name package) stream)) + + +(defclass package-call-node (call-node) ()) + +(proclaim '(inline make-package-call-node)) +(defun make-package-call-node (object) + (make-instance 'package-call-node :object object)) + +(defmethod node-object-name ((node package-call-node)) + (package-name (node-object node))) + +(defmethod display-node ((node package-call-node) stream) + (with-output-as-presentation (stream node 'package-call-node) + (present (node-object node) 'package :stream stream))) + +(define-browser-type :package package :graphical + () + (:uses make-package-call-node package-browser-make-root + (:arc-drawer draw-arrow* :arc-drawing-options (:from-head t :to-head nil))) + (:used-by make-package-call-node package-browser-make-root + (:arc-drawer draw-arrow*))) + +(defun package-browser-make-root (object) + (typecase object + (package + (make-package-call-node object)) + ((or string symbol) + (let ((package (find-package object))) + (and package + (make-package-call-node package)))))) + +(defmethod node-generate-inferior-objects ((node package-call-node) (type (eql ':uses))) + (package-use-list (node-object node))) + +(defmethod node-any-inferior-objects-p ((node package-call-node) (type (eql ':uses))) + (not (null (package-use-list (node-object node))))) + +(defmethod node-generate-inferior-objects ((node package-call-node) (type (eql ':used-by))) + (package-used-by-list (node-object node))) + +(defmethod node-any-inferior-objects-p ((node package-call-node) (type (eql ':used-by))) + (not (null (package-used-by-list (node-object node))))) + + +(defclass package-symbols-subnode (call-subnode) ()) + +(proclaim '(inline make-package-symbols-subnode)) +(defun make-package-symbols-subnode (package-node symbols) + (let ((subnode (make-instance 'package-symbols-subnode :object symbols))) + (setf (node-superiors subnode) (list package-node)) + subnode)) + +(defmethod node-object-name ((node package-symbols-subnode)) + (format nil "Instance variables of ~S" (node-object-name (first (node-superiors node))))) + +(defmethod display-node ((node package-symbols-subnode) stream) + (let ((symbols (node-object node))) + (with-output-as-presentation (stream node 'package-symbols-subnode + :single-box t) + (surrounding-output-with-border (stream :shape :rectangle) + (formatting-table (stream :multiple-columns t) + (dolist (symbol symbols) + (formatting-row (stream) + (formatting-cell (stream) + (present symbol 'symbol :stream stream))))))))) + + +;;; File system browsing (how can I resist?) + +;; As the object, we have a list of the form (PATHNAME . PROPERTIES) +(defclass filesystem-call-node + (call-node) + ((directory-p :reader filesystem-node-directory-p :initarg :directory-p))) + +(proclaim '(inline make-filesystem-call-node)) +(defun make-filesystem-call-node (object) + (destructuring-bind (pathname &rest properties) object + (let* ((directory-p (getf properties :directory)) + (pathname (if directory-p + (make-pathname :name :wild + :type :wild + :version :newest + :directory (append (pathname-directory pathname) + (list (pathname-name pathname))) + :defaults pathname) + pathname))) + (make-instance 'filesystem-call-node :object `(,pathname ,@properties) + :directory-p directory-p)))) + +(defmethod node-object-name ((node filesystem-call-node)) + (let ((pathname (first (node-object node)))) + (namestring pathname))) + +(defmethod display-node ((node filesystem-call-node) stream) + (let ((pathname (first (node-object node)))) + (with-output-as-presentation (stream node 'filesystem-call-node) + (with-output-as-presentation (stream pathname 'pathname) + (format stream "~A" pathname))))) + +(define-browser-type :filesystem pathname :textual + () + (:filesystem make-filesystem-call-node filesystem-browser-make-root + nil)) + +(defun filesystem-browser-make-root (object) + (when (pathnamep object) + (let ((pathname (make-pathname :name :wild + :type :wild + :version :newest + :defaults object))) + (make-instance 'filesystem-call-node :object `(,pathname :directory t) + :directory-p t)))) + +(defmethod node-generate-inferior-objects ((node filesystem-call-node) (type (eql ':filesystem))) + (when (filesystem-node-directory-p node) + (let* ((pathname (first (node-object node))) + (dirlist (directory-and-properties + (make-pathname :name :wild + :type :wild + :version :newest + :defaults pathname)))) + (sort dirlist #'(lambda (x y) + (if (string-equal (pathname-name x) (pathname-name y)) + (string-lessp (pathname-type x) (pathname-type y)) + (string-lessp (pathname-name x) (pathname-name y)))) + :key #'first)))) + +(defmethod node-any-inferior-objects-p ((node filesystem-call-node) (type (eql ':filesystem))) + (filesystem-node-directory-p node)) + +(defun directory-and-properties (pathname) + #+Genera (cdr (fs:directory-list pathname)) + #-Genera (mapc #'list (directory pathname))) + + +;;; Lisp object browsing + +(defclass lisp-object-call-node (call-node) ()) + +(proclaim '(inline make-lisp-object-call-node)) +(defun make-lisp-object-call-node (object) + (make-instance 'lisp-object-call-node :object object)) + +;; Kludge to prevent explosions when we click on a node which doesn't +;; have a reasonable printed representation +(defmethod print-object :around ((node lisp-object-call-node) stream) + (handler-case + (call-next-method node stream) + (print-not-readable))) + +(defvar *unbound-marker* (list nil)) +(defmethod display-node ((node lisp-object-call-node) stream) + (let ((object (node-object node))) + (labels ((draw (stream) + ;;--- This should produce a more graphical presentation + (with-output-as-presentation (stream node 'lisp-object-call-node) + (with-browser-io-environment + (if (eql object *unbound-marker*) + (princ "Unbound" stream) + (prin1 object stream)))))) + (declare (dynamic-extent #'draw)) + (if (node-recurses node) + (surrounding-output-with-border (stream :shape :rectangle) + (draw stream)) + (draw stream))))) + +(define-browser-type :lisp-object expression :graphical + () + (:objects make-lisp-object-call-node lisp-object-browser-make-root + (:arc-drawer draw-arrow*))) + +(defun lisp-object-browser-make-root (object) + (make-lisp-object-call-node + (if (and (listp object) + (fboundp (first object))) + ;; Handles both quoted forms and calls to functions + (eval object) + (if (symbolp object) + (symbol-value object) + object)))) + +(defmethod node-generate-inferior-objects ((node lisp-object-call-node) (type (eql ':objects))) + (let ((object (node-object node))) + (cond #+Genera + ((si:named-structure-p object) + ;; Generate a list of all of the structures slots + ;;--- How to arrange for the slot names to be printed? + (let* ((description (get (or (and (arrayp object) + (si:named-structure-symbol object)) + (and (listp object) + (symbolp (car object)) + (car object))) + 'si:defstruct-description))) + (loop for (slot-name . slot-description) + in (si:defstruct-description-slot-alist description) + as form = `(,(si:defstruct-slot-description-ref-macro-name slot-description) + ',object) + collect (eval form)))) + ;;--- What do we do for INSTANCEP? + ((si:instancep object) + #+Genera (setq object (si:follow-structure-forwarding object)) + ;;--- How to arrange for the slot names to be printed? + ;; This works for Genera Flavors because they are embedded in CLOS + (let* ((class (class-of object)) + (slots (clos:class-slots class))) + (loop for slot in slots + as slot-name = (clos:slot-definition-name slot) + collect (if (slot-boundp object slot-name) + (slot-value object slot-name) + *unbound-marker*)))) + ((stringp object) nil) + ((arrayp object) (coerce object 'list)) + ((consp object) object) + (t nil)))) + +(defmethod node-any-inferior-objects-p ((node lisp-object-call-node) (type (eql ':objects))) + (let ((object (node-object node))) + (or (consp object) + ;;--- What do we do for INSTANCEP? + (si:instancep object) + (and (arrayp object) + (not (stringp object)))))) + + +;;; The browser itself + +(define-application-frame browser () + ((graph-type :initform :graphical) + (browser-type :initform nil) + (browser-subtype :initform nil) + (browser-ptype :initform nil) + (browser-options :initform nil) + (node-maker :initform #'false) + (root-node-maker :initform #'false) + (grapher-args :initform nil) + (tree-depth :initform 1) + (merge-duplicate-nodes :initform t) + (root-nodes :initform nil) + (all-nodes :initform nil) + (auto-snapshot :initform t) + (snapshots :initform nil)) + (:command-definer t) + (:command-table (browser :inherit-from (accept-values-pane))) + (:panes + ((title :title + :display-after-commands t + :display-function 'display-title-pane + :default-text-style '(:sans-serif :bold :large)) + (graph :application + :display-function 'display-graph-pane + :display-after-commands t + :incremental-redisplay t + :scroll-bars :both) + (commands :command-menu + :display-function '(display-command-menu :n-rows 2)) + (interactor :interactor) + (control-panel :accept-values + :display-function '(accept-values-pane-displayer + :displayer accept-call-graph-options)))) + (:layout + ((default + (:column 1 + (title :compute) + (graph :rest) + (:row 1/4 + (:column :rest + (commands 1/4) + (interactor :rest)) + (control-panel 2/5))))))) + +#+Genera (define-genera-application browser :select-key #\Triangle) +#+Genera (zwei:defindentation (define-browser-command 0 3 1 3 2 1)) + +(defmethod configure-for-browser-type ((browser browser) type subtype) + (with-slots (auto-snapshot browser-type browser-subtype + node-maker root-node-maker graph-type grapher-args + browser-ptype browser-options) browser + (when auto-snapshot + (snapshot-current-graph browser)) + (setq browser-type type + browser-subtype subtype) + (multiple-value-bind (maker root-maker gr-type gr-args ptype options) + (browser-type-information browser-type browser-subtype) + (setq node-maker maker + root-node-maker root-maker + graph-type gr-type + grapher-args gr-args + browser-ptype ptype + browser-options options)))) + +(defmethod initialize-instance :after ((browser browser) &key) + (with-slots (root-nodes all-nodes) browser + (setq root-nodes nil + all-nodes nil) + (configure-for-browser-type + browser + (first *browser-types*) + (first (browser-type-subtypes (first *browser-types*)))))) + +(defmethod display-title-pane ((browser browser) stream) + (with-slots (root-nodes browser-type browser-subtype) browser + (if (or (null browser-type) (null root-nodes)) + (centering-line (stream) + (format stream "Browser")) + (updating-output (stream :unique-id 'title + :cache-value (list root-nodes browser-type browser-subtype) + :cache-test #'equal) + (centering-line (stream) + (with-browser-io-environment + (format stream "~@(~A~) browser: ~(~A~) of ~S~:[~;, etc.~]" + browser-type browser-subtype + (node-object-name (first root-nodes)) + (cdr root-nodes)))))))) + +(defgeneric display-graph-pane-1 (browser type stream)) + +(defvar *graph-displayer-types* nil) +(defmacro define-graph-displayer (type (browser stream) &body body) + `(progn + (pushnew ',type *graph-displayer-types*) + (defmethod display-graph-pane-1 ((,browser browser) (type (eql ',type)) ,stream) + ,@body))) + +(defun draw-browser-graph (root-nodes node-printer inferior-producer + &key (stream *standard-output*) + (orientation :horizontal) + (center-nodes nil) + (merge-duplicates nil) + (arc-drawer #'draw-line*) + (arc-drawing-options nil) + (generation-separation + *default-generation-separation*) + (within-generation-separation + *default-within-generation-separation*) + node-filter) + (flet ((inferior-producer (node) + (let ((inferiors (funcall inferior-producer node))) + (if (null node-filter) + inferiors + (delete-if-not node-filter inferiors))))) + (declare (dynamic-extent #'inferior-producer)) + (format-graph-from-roots root-nodes node-printer #'inferior-producer + :stream stream + :orientation orientation + :center-nodes center-nodes + :merge-duplicates merge-duplicates + :arc-drawer arc-drawer + :arc-drawing-options arc-drawing-options + :generation-separation generation-separation + :within-generation-separation within-generation-separation))) + +(define-graph-displayer :graphical (browser stream) + (with-slots (root-nodes merge-duplicate-nodes browser-options grapher-args) browser + (updating-output (stream :unique-id root-nodes) + (apply #'draw-browser-graph root-nodes #'display-node #'node-inferiors + :stream stream + :orientation :horizontal + :merge-duplicates merge-duplicate-nodes + :node-filter (getf browser-options :display-filter) + grapher-args)))) + +(define-graph-displayer :textual (browser stream) + (with-slots (root-nodes browser-options) browser + (let ((filter (getf browser-options :display-filter))) + (labels ((display (node stream indentation) + (when (or (null filter) + (funcall filter node)) + (fresh-line stream) + (dotimes (i indentation) + (declare (ignore i)) + (write-char #\Space stream)) + (display-node node stream) + (dolist (inferior (node-inferiors node)) + (display inferior stream (+ indentation 2)))))) + (declare (dynamic-extent #'display)) + (updating-output (stream :unique-id root-nodes) + (with-end-of-page-action (stream :allow) + (with-end-of-line-action (stream :allow) + (dolist (node root-nodes) + (display node stream 0))))))))) + +(defmethod display-graph-pane ((browser browser) stream) + (with-slots (root-nodes graph-type) browser + (when root-nodes + (display-graph-pane-1 browser graph-type stream)))) + +(defmethod generate-call-graph ((browser browser) nodes + &optional (depth (slot-value browser 'tree-depth))) + (with-slots (browser-subtype) browser + (when nodes + (let ((generated nil)) + (labels + ((collect-inferiors (node parent-node depth) + ;; Disallow direct recursion in a simple-minded way + (when (and (plusp depth) + (not (eql node parent-node))) + (let ((places nil) + (inferior-objects + (filter-generated-objects + browser + (node-generate-inferior-objects node browser-subtype)))) + (when inferior-objects + (setq generated t) ;we generated something + ;; Use this hairy DO stuff to detect dotted lists + (do ((place inferior-objects (cdr place))) + (()) + (when (null place) (return nil)) + (let* ((object (if (consp place) (car place) place)) + (inferior-node + (find-node-for-object browser object))) + (cond ((member place places) + ;; Beware of circular lists + (setf (node-recurses node) t) + (return nil)) + (t + (push place places))) + (cond ((node-recurses-p browser node inferior-node) + (setf (node-recurses node) t)) + (t + (unless (member node (node-superiors inferior-node)) + (setf (node-superiors inferior-node) + (nconc (node-superiors inferior-node) (list node)))) + (unless (member inferior-node (node-inferiors node) + :test #'node-eql) + (setf (node-inferiors node) + (nconc (node-inferiors node) (list inferior-node)))))) + ;; Recursively collect inferiors for these nodes + (collect-inferiors inferior-node node (1- depth)) + (unless (consp place) (return nil))))))))) + (declare (dynamic-extent #'collect-inferiors)) + (dolist (node nodes) + (collect-inferiors node nil depth))) + generated)))) + +;; Find or intern a new node. +(defmethod find-node-for-object ((browser browser) object &key (test #'eql)) + (with-slots (all-nodes node-maker) browser + (dolist (node all-nodes) + (when (funcall test object (node-object node)) + (return-from find-node-for-object node))) + (let ((node (funcall node-maker object))) + (setq all-nodes (nconc all-nodes (list node))) + node))) + +(defmethod node-recurses-p ((browser browser) node inferior) + (with-slots (all-nodes) browser + (or (eql node inferior) ;quick test often succeeds + (let ((mark-table + #+Genera (scl:make-hash-table :size (length all-nodes) :number-of-values 0) + #-Genera (make-hash-table :size (length all-nodes)))) + (labels ((recurses (inferiors) + (when (member node inferiors) + (return-from node-recurses-p t)) + (dolist (inferior inferiors) + (unless (gethash inferior mark-table) + (setf (gethash inferior mark-table) t) + (recurses (node-inferiors inferior)))))) + (declare (dynamic-extent #'recurses)) + (setf (gethash node mark-table) t) + (setf (gethash inferior mark-table) t) + (recurses (node-inferiors inferior)) + nil))))) + +;; Given a generator, create the call graph for a node. +(defmethod filter-generated-objects ((browser browser) objects) + (with-slots (browser-options) browser + (let ((predicate (getf browser-options :object-filter))) + (if (null predicate) + objects + (delete-if-not predicate objects))))) + +(defmethod generate-upward-call-graph ((browser browser) inferior-node subtype) + (let ((superior-objects + (filter-generated-objects + browser + (node-generate-inferior-objects inferior-node subtype)))) + (when superior-objects + (dolist (object superior-objects) + (let ((node (find-node-for-object browser object))) + (cond ((node-recurses-p browser node inferior-node) + (setf (node-recurses node) t)) + (t + (unless (member node (node-superiors inferior-node)) + (setf (node-superiors inferior-node) + (nconc (node-superiors inferior-node) (list node)))) + (unless (member inferior-node (node-inferiors node) + :test #'node-eql) + (setf (node-inferiors node) + (nconc (node-inferiors node) (list inferior-node)))))))) + (recompute-root-nodes browser) + t))) + +(defmethod recompute-root-nodes ((browser browser)) + (with-slots (all-nodes root-nodes) browser + (loop for node in all-nodes + when (null (node-superiors node)) + collect node into new-roots + finally (unless (node-set-equal new-roots root-nodes) + (setq root-nodes new-roots))))) + +(defun node-set-equal (nodes1 nodes2) + (let ((l1 (length nodes1)) + (l2 (length nodes2))) + (and (= l1 l2) + (let ((mark-table + #+Genera (scl:make-hash-table :size l1 :number-of-values 0) + #-Genera (make-hash-table :size l1))) + (dolist (node nodes1) + (setf (gethash (node-object node) mark-table) t)) + (every #'(lambda (node) (gethash (node-object node) mark-table)) + nodes2))))) + +(defmethod accept-call-graph-options ((browser browser) stream) + (with-slots (browser-type browser-subtype tree-depth + merge-duplicate-nodes auto-snapshot browser-options + root-nodes root-node-maker all-nodes) browser + (flet ((accept (type default prompt query-id) + (fresh-line stream) + (accept type + :stream stream :default default + :query-identifier query-id :prompt prompt))) + (declare (dynamic-extent #'accept)) + (multiple-value-bind (new-type nil type-changed) + (accept `(member ,@*browser-types*) (or browser-type (first *browser-types*)) + "Browser type" 'type) + (let* ((sub-ptype + (browser-type-subtypes new-type)) + (new-subtype + (accept `(member ,@sub-ptype) + (if type-changed (first sub-ptype) browser-subtype) + "Browser subtype" 'subtype)) + (new-depth + (accept '(integer 1 10) tree-depth + "Starting depth" 'depth)) + (new-merge + (accept 'boolean merge-duplicate-nodes + "Merge duplicate nodes" 'merge)) + (new-auto-snapshot + (accept 'boolean auto-snapshot + "Automatic snapshots" 'auto-snapshot))) + (let ((additional-dialog (getf browser-options :additional-browser-options))) + (when additional-dialog + (funcall additional-dialog browser stream))) + (setq tree-depth new-depth + merge-duplicate-nodes new-merge + auto-snapshot new-auto-snapshot) + (when (or (not (eql new-type browser-type)) + (not (eql new-subtype browser-subtype))) + (configure-for-browser-type browser new-type new-subtype) + (when root-nodes + (loop for node in root-nodes + as new-node = (funcall root-node-maker (node-object node)) + when new-node + collect new-node into new-root-nodes + finally + (setq root-nodes new-root-nodes) + ;; ALL-NODES and ROOT-NODES must not be EQ lists... + (setq all-nodes (copy-list root-nodes)))) + ;; Regenerate and redisplay the call graph + (generate-call-graph browser root-nodes) + (redisplay-frame-pane *application-frame* 'graph :force-p t))))))) + + +;;; Browser commands + +(define-browser-command (com-show-graph :name t :menu t) + ((objects (with-slots (browser-ptype) *application-frame* + `(or (sequence ,browser-ptype) call-node)) + :prompt "the name of an object" + :default nil)) + (with-slots (auto-snapshot root-node-maker root-nodes all-nodes) *application-frame* + (when auto-snapshot + (snapshot-current-graph *application-frame*)) + (if (typep objects 'call-node) + (setq root-nodes (list (funcall root-node-maker (node-object objects)))) + (loop for object in objects + as new-node = (funcall root-node-maker object) + when new-node + collect new-node into new-root-nodes + finally (setq root-nodes new-root-nodes))) + ;; ALL-NODES and ROOT-NODES must not be EQ lists... + (setq all-nodes (copy-list root-nodes)) + (window-clear (get-frame-pane *application-frame* 'graph)) + (generate-call-graph *application-frame* root-nodes) + (redisplay-frame-pane *application-frame* 'graph :force-p t))) + +(define-gesture-name :show-graph :button :left :shifts (:shift)) + +(define-presentation-to-command-translator show-graph + (call-node com-show-graph browser + :gesture :show-graph + :tester ((object) + (presentation-typep + (node-object object) (slot-value *application-frame* 'browser-ptype)))) + (object) + (list (node-object object))) + +(define-browser-command (com-decache :menu t) () + (with-slots (root-nodes all-nodes) *application-frame* + (setq root-nodes nil + all-nodes nil) + (window-clear (get-frame-pane *application-frame* 'graph)))) + +(define-browser-command (com-redisplay :menu t) () + (window-clear (get-frame-pane *application-frame* 'graph)) + (redisplay-frame-pane *application-frame* 'graph :force-p t)) + +(define-browser-command (com-hardcopy-graph :name t :menu "Hardcopy") + (&key (file 'pathname + :default (make-pathname :name "GRAPH-HARDCOPY" + :type "PS" + :defaults (user-homedir-pathname) + :case :common) + :documentation "File in which to put the PostScript result") + (orientation '(member :landscape :portrait) + :default :portrait + :documentation "Orientation to use on the paper")) + (with-slots (browser-subtype root-nodes) *application-frame* + (with-open-file (file-stream file :direction :output) + (with-output-to-postscript-stream (stream file-stream + :orientation orientation + :multi-page t) + (with-text-style (stream '(:sans-serif :bold :large)) + (display-title-pane *application-frame* stream)) + (terpri stream) + (terpri stream) + (display-graph-pane *application-frame* stream))))) + +(define-browser-command (com-set-graph-type :name t) + ((type `(member ,@*graph-displayer-types*))) + (with-slots (graph-type) *application-frame* + (unless (eql type graph-type) + (setq graph-type type) + (redisplay-frame-pane *application-frame* 'graph :force-p t)))) + +(define-browser-command com-show-node-inferiors + ((node 'call-node :prompt "node to show inferiors for")) + (when (generate-call-graph *application-frame* (list node) 1) + (tick-node node))) + +(define-presentation-to-command-translator show-node-inferiors + (call-node com-show-node-inferiors browser + :gesture :select + :tester ((object) + (node-any-inferior-objects-p + object (slot-value *application-frame* 'browser-subtype)))) + (object) + (list object)) + +(define-browser-command com-hide-node-inferiors + ((node 'call-node :prompt "node to hide inferiors of")) + (when (node-inferiors node) + (setf (node-inferiors node) nil) + (tick-node node))) + +(define-presentation-to-command-translator hide-node-inferiors + (call-node com-hide-node-inferiors browser + :gesture :describe + :tester ((object) + (not (null (node-inferiors object))))) + (object) + (list object)) + +(define-browser-command com-delete-node + ((node 'call-node :prompt "node to delete")) + (when (node-superiors node) + (dolist (superior (node-superiors node)) + (setf (node-inferiors superior) (delete node (node-inferiors superior)))) + (tick-node node))) + +(define-presentation-to-command-translator delete-node + (call-node com-delete-node browser + :gesture :describe + :tester ((object) (and (null (node-inferiors object)) + (not (null (node-superiors object)))))) + (object) + (list object)) + +(define-browser-command com-show-node-superiors + ((node 'call-node + :prompt "node to show superiors for")) + (with-slots (browser-type browser-subtype) *application-frame* + (let* ((subtypes (browser-type-subtypes browser-type)) + (subtype (block find-subtype + (dolist (subtype subtypes) + (unless (eql browser-subtype subtype) + (return-from find-subtype subtype)))))) + (when (and subtype + (generate-upward-call-graph *application-frame* node subtype)) + (tick-node node))))) + +(define-presentation-to-command-translator show-node-superiors + (call-node com-show-node-superiors browser + :gesture nil + :menu t) + (object) + (list object)) + +;; Given a node, replace it by another one which contains the inferiors of +;; all of its inferiors (i.e., splice out the intermediates so that the +;; graph takes up less space). +(define-browser-command com-ellipsize-node + ((node 'call-node :prompt "node to ellipsize")) + (with-slots (all-nodes) *application-frame* + (let ((ellipsis (make-ellipsis-call-node (node-object-name node) node))) + ;; Dike out all references to the ellipsized node + (dolist (n all-nodes) + (nsubstitute ellipsis node (node-inferiors n))) + (nsubstitute ellipsis node all-nodes) + (incf (node-tick node)) + (tick-node ellipsis)))) + +(define-presentation-to-command-translator ellipsize-node + ((or call-node ellipsis-call-node) com-ellipsize-node browser + :gesture :delete) + (object) + (list object)) + +(define-browser-command com-unellipsize-node + ((ellipsis 'ellipsis-call-node :prompt "node to unellipsize" :gesture :select)) + (with-slots (all-nodes) *application-frame* + (let ((node (ellipsis-node-replaced-node ellipsis))) + ;; Replace all references to the ellipsized node + (dolist (n all-nodes) + (nsubstitute node ellipsis (node-inferiors n))) + (nsubstitute node ellipsis all-nodes) + (tick-node node)))) + + +;;; Snapshotting + +(defstruct snapshot + graph-type + browser-type + browser-subtype + browser-ptype + browser-options + node-maker + root-node-maker + grapher-args + tree-depth + merge-duplicate-nodes + root-nodes + all-nodes) + +(define-presentation-type snapshot (&optional snapshots)) + +(define-presentation-method accept ((type snapshot) stream (view textual-view) &key) + (values + (with-browser-io-environment + (completing-from-suggestions (stream) + (dolist (snapshot snapshots) + (suggest (format nil "~:(~A~) ~:(~A~) ~S" + (snapshot-browser-type snapshot) + (snapshot-browser-subtype snapshot) + (mapcar #'node-object-name (snapshot-root-nodes snapshot))) + snapshot)))))) + +(define-presentation-method present (snapshot (type snapshot) stream (view textual-view) &key) + (with-browser-io-environment + (format stream "~:(~A~) ~:(~A~) ~S" + (snapshot-browser-type snapshot) + (snapshot-browser-subtype snapshot) + (mapcar #'node-object-name (snapshot-root-nodes snapshot))))) + +(defmethod snapshot-current-graph ((browser browser)) + (with-slots (graph-type browser-type browser-subtype + browser-ptype browser-options node-maker + root-node-maker grapher-args tree-depth + merge-duplicate-nodes root-nodes all-nodes snapshots) browser + (let ((snapshot (make-snapshot :graph-type graph-type + :browser-type browser-type + :browser-subtype browser-subtype + :browser-ptype browser-ptype + :browser-options (copy-list browser-options) + :node-maker node-maker + :root-node-maker root-node-maker + :grapher-args grapher-args + :tree-depth tree-depth + :merge-duplicate-nodes merge-duplicate-nodes + :root-nodes (copy-list root-nodes) + :all-nodes (copy-list all-nodes)))) + (flet ((snapshot-equal (s1 s2) + (and (eql (snapshot-browser-type s1) (snapshot-browser-type s2)) + (eql (snapshot-browser-subtype s1) (snapshot-browser-subtype s2)) + (equal (snapshot-root-nodes s1) (snapshot-root-nodes s2))))) + (declare (dynamic-extent #'snapshot-equal)) + (let ((old-snapshot (member snapshot snapshots :test #'snapshot-equal))) + (if old-snapshot + (setf (car old-snapshot) snapshot) + (setq snapshots (nconc snapshots (list snapshot))))))))) + +(define-browser-command (com-snapshot-graph :menu "Snapshot") () + (snapshot-current-graph *application-frame*)) + +(define-browser-command (com-show-snapshots :menu t) () + (with-slots (snapshots) *application-frame* + (dolist (snapshot snapshots) + (fresh-line) + (present snapshot 'snapshot)))) + +(define-browser-command (com-recover-snapshot :menu t) + ((snapshot (with-slots (snapshots) *application-frame* + `(snapshot ,snapshots)) + :prompt "snapshot to recover")) + (with-slots (browser-type browser-subtype root-nodes graph-type + browser-ptype browser-options node-maker + root-node-maker grapher-args tree-depth + merge-duplicate-nodes all-nodes) *application-frame* + (unless (and (eql browser-type (snapshot-browser-type snapshot)) + (eql browser-subtype (snapshot-browser-subtype snapshot)) + (equal root-nodes (snapshot-root-nodes snapshot))) + (setq graph-type (snapshot-graph-type snapshot) + browser-type (snapshot-browser-type snapshot) + browser-subtype (snapshot-browser-subtype snapshot) + browser-ptype (snapshot-browser-ptype snapshot) + browser-options (copy-list (snapshot-browser-options snapshot)) + node-maker (snapshot-node-maker snapshot) + root-node-maker (snapshot-root-node-maker snapshot) + grapher-args (snapshot-grapher-args snapshot) + tree-depth (snapshot-tree-depth snapshot) + merge-duplicate-nodes (snapshot-merge-duplicate-nodes snapshot) + root-nodes (copy-list (snapshot-root-nodes snapshot)) + all-nodes (copy-list (snapshot-all-nodes snapshot))) + (redisplay-frame-pane *application-frame* 'graph :force-p t)))) + +(define-presentation-to-command-translator recover-snapshot + (snapshot com-recover-snapshot browser + :gesture :select) + (object) + (list object)) + +(define-browser-command com-remove-snapshot + ((snapshot 'snapshot :prompt "snapshot to remove" :gesture :delete)) + (with-slots (snapshots) *application-frame* + (setq snapshots (delete snapshot snapshots)))) + + +;;; Less general browser commands, mostly pertaining to subnodes + +(define-browser-command com-remove-subnode + ((subnode 'call-subnode :prompt "subnode to remove" :gesture :delete)) + (with-slots (all-nodes) *application-frame* + (let ((node (first (node-superiors subnode)))) + (setf (node-inferiors node) (delete subnode (node-inferiors node))) + (setq all-nodes (delete subnode all-nodes)) + (tick-node subnode)))) + +(defun subnode-object-present-in-node (node object &key (test #'eql)) + (dolist (subnode (node-inferiors node)) + (when (and (typep subnode 'call-subnode) + (funcall test object (node-object subnode))) + (return-from subnode-object-present-in-node t))) + nil) + +(define-gesture-name :subnode-1 :button :left :shifts (:control :meta)) +(define-gesture-name :subnode-2 :button :middle :shifts (:control :meta)) + +(define-browser-command com-show-clos-slots + ((class-node 'class-call-node + :prompt "class node to show slots for" :gesture :subnode-1)) + (let* ((class (node-object class-node)) + (slots (sort (mapcar #'clos:slot-definition-name (clos:class-direct-slots class)) + #'string-lessp))) + (when (and slots + (not (subnode-object-present-in-node class-node slots :test #'equal))) + (let ((subnode (make-clos-slot-call-subnode class-node slots))) + (push subnode (node-inferiors class-node)) + (tick-node subnode))))) + +(define-browser-command com-show-clos-methods + ((class-node 'class-call-node + :prompt "class node to show methods for" :gesture :subnode-2)) + (let* ((class (node-object class-node)) + (methods (clos:specializer-direct-methods class)) + (method-list + (loop for method in methods + collect (list (clos:method-generic-function method) method)))) + (setq method-list (sort method-list #'string-lessp + :key #'(lambda (item) + (let ((name (clos:generic-function-name (first item)))) + (if (listp name) (second name) name))))) + (when (and method-list + (not (subnode-object-present-in-node class-node method-list + :test #'equal))) + (let ((subnode (make-clos-method-call-subnode class-node method-list))) + (push subnode (node-inferiors class-node)) + (tick-node subnode))))) + + +(define-browser-command com-show-exported-symbols + ((package-node 'package-call-node + :prompt "package node to show exported symbols of" :gesture :subnode-1)) + (let ((package (node-object package-node)) + symbols) + (do-external-symbols (symbol package) + (when (eql (symbol-package symbol) package) + (push symbol symbols))) + (setq symbols (sort symbols #'string-lessp :key #'symbol-name)) + (when (and symbols + (not (subnode-object-present-in-node package-node symbols :test #'equal))) + (let ((subnode (make-package-symbols-subnode package-node symbols))) + (push subnode (node-inferiors package-node)) + (tick-node subnode))))) diff --git a/misc/pixmaps.lisp b/misc/pixmaps.lisp new file mode 100644 index 00000000..a9bad955 --- /dev/null +++ b/misc/pixmaps.lisp @@ -0,0 +1,425 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10; Patch-File: T; Lowercase: Yes -*- +;;; Patch file for Private version 0.0 +;;; Reason: Add support for pixmaps and pixmap streams to CLIM. +;;; +;;; Function CLIM:WITH-OUTPUT-TO-PIXMAP-STREAM: New, creates a pixmap stream. +;;; +;;; DEFOPERATION CLIM:COPY-AREA: Replacement for COPY-AREA-INTERNAL. +;;; Function (CLOS:METHOD CLIM::WINDOW-SHIFT-VISIBLE-REGION (CLIM::WINDOW-MIXIN T T T T T T T T)): +;;; Use it. +;;; CLOS class CLIM::BASIC-PIXMAP: The basic pixmap class, with PIXMAP-WIDTH and PIXMAP-HEIGHT +;;; readers for the allocated width and height. +;;; +;;; The methods for Genera sheets. +;;; Function (CLOS:METHOD CLIM:COPY-AREA (CLIM::SHEET-IMPLEMENTATION-MIXIN T T T T T T)): .. +;;; CLOS class CLIM::GENERA-PIXMAP: .. +;;; Function (CLOS:METHOD CLIM:ALLOCATE-PIXMAP (CLIM::SHEET-IMPLEMENTATION-MIXIN T T)): .. +;;; Function (CLOS:METHOD CLIM:DEALLOCATE-PIXMAP (CLIM::GENERA-PIXMAP)): .. +;;; Function (CLOS:METHOD CLIM:COPY-TO-PIXMAP (CLIM::SHEET-IMPLEMENTATION-MIXIN T T T T)): .. +;;; Function (CLOS:METHOD CLIM:COPY-FROM-PIXMAP (CLIM::GENERA-PIXMAP T T T T CLIM::SHEET-IMPLEMENTATION-MIXIN T T)): .. +;;; CLOS class CLIM::GENERA-PIXMAP-STREAM: .. +;;; function (CLOS:METHOD CLOS:INITIALIZE-INSTANCE (CLIM::GENERA-PIXMAP-STREAM) :AFTER): .. +;;; Function (CLOS:METHOD (SETF CLIM:MEDIUM-FOREGROUND) (T CLIM::GENERA-PIXMAP-STREAM) :AFTER): .. +;;; Function (CLOS:METHOD (SETF CLIM:MEDIUM-BACKGROUND) (T CLIM::GENERA-PIXMAP-STREAM) :AFTER): .. +;;; Function (CLOS:METHOD CLIM::INVOKE-WITH-OUTPUT-TO-PIXMAP (CLIM::SHEET-IMPLEMENTATION-MIXIN T)): .. +;;; +;;; The methods for CLX windows. +;;; Function (CLOS:METHOD CLIM:COPY-AREA (CLIM::CLX-WINDOW T T T T T T)): .. +;;; CLOS class CLIM::CLX-PIXMAP: .. +;;; Function (CLOS:METHOD CLIM:ALLOCATE-PIXMAP (CLIM::CLX-WINDOW T T)): .. +;;; Function (CLOS:METHOD CLIM:DEALLOCATE-PIXMAP (CLIM::CLX-PIXMAP)): .. +;;; Function (CLOS:METHOD CLIM:COPY-TO-PIXMAP (CLIM::CLX-WINDOW T T T T)): .. +;;; Function (CLOS:METHOD CLIM:COPY-FROM-PIXMAP (CLIM::CLX-PIXMAP T T T T CLIM::CLX-WINDOW T T)): .. +;;; CLOS class CLIM::CLX-PIXMAP-STREAM: .. +;;; Function (CLOS:METHOD CLOS:INITIALIZE-INSTANCE (CLIM::CLX-PIXMAP-STREAM) :AFTER): .. +;;; function (CLOS:METHOD (SETF CLIM:MEDIUM-FOREGROUND) (T CLIM::CLX-PIXMAP-STREAM) :AFTER): .. +;;; Function (CLOS:METHOD (SETF CLIM:MEDIUM-BACKGROUND) (T CLIM::CLX-PIXMAP-STREAM) :AFTER): .. +;;; function (CLOS:METHOD CLIM::INVOKE-WITH-OUTPUT-TO-PIXMAP (CLIM::CLX-WINDOW T)): .. +;;; Written by SWM, 18-Oct-91 18:09:01 +;;; while running on Evening Grosbeak from FEP0:>dSCRC-439-25-from-IH-Sys439-25.load.1 +;;; with Experimental System 439.45, Experimental CLOS 424.5, Experimental RPC 428.1, +;;; Experimental Embedding Support 420.0, Experimental MacIvory Support 434.0, +;;; Experimental UX Support 429.0, Experimental Development Utilities 424.4, +;;; Experimental Old TV 422.0, Experimental Zwei 422.5, Experimental Utilities 432.0, +;;; Experimental RPC Development 423.0, Experimental MacIvory Development 422.0, +;;; Experimental UX Development 428.0, Experimental Server Utilities 430.1, +;;; Experimental Serial 423.1, Experimental Hardcopy 433.0, Experimental Zmail 430.0, +;;; Experimental LMFS Defstorage 406.0, Experimental SCSI 419.0, +;;; Experimental Tape 432.1, Experimental LMFS 431.2, Experimental NSage 428.0, +;;; Experimental Extended Help 429.0, Experimental CL Developer 416.0, +;;; Experimental Documentation Database 429.13, Experimental IP-TCP 438.2, +;;; Experimental IP-TCP Documentation 411.0, Experimental CLX 434.0, +;;; Experimental X Remote Screen 432.0, Experimental X Documentation 410.0, +;;; Experimental NFS Client 428.0, Experimental NFS Documentation 412.0, +;;; Experimental DNA 427.0, Experimental Metering 432.0, +;;; Experimental Metering Substrate 432.0, Experimental Conversion Tools 423.0, +;;; Experimental Hacks 428.0, Experimental Mac Dex 421.0, +;;; Experimental HyperCard/MacIvory 421.0, Experimental Statice Runtime 412.10, +;;; Experimental Statice 433.0, Experimental Statice Browser 409.0, +;;; Experimental Statice Documentation 415.0, Experimental CLIM 33.21, +;;; Experimental CLIM Documentation 33.1, Experimental CLIM Demo 33.2, +;;; Experimental Lock Simple 425.0, Version Control 404.4, Compare Merge 403.0, +;;; VC Documentation 401.0, Symbolics In-House 431.0, +;;; Symbolics In-House Documentation 413.6, SCRC 429.0, Weather User 413.0, +;;; Logical Pathnames Translation Files NEWEST, cold load 2, microcode 3645-MIC 430, +;;; FEP 127, FEP0:>V127-lisp.flod(64), FEP0:>V127-loaders.flod(64), +;;; FEP0:>V127-info.flod(64), FEP0:>V127-debug.flod(38), 1067x752 B&W Screen, +;;; Machine serial number 10129, + + +#+Genera +(SYSTEM-INTERNALS:FILES-PATCHED-IN-THIS-PATCH-FILE + "SYS:CLIM;CLIM;CLX-IMPLEMENTATION.LISP.236" + "SYS:CLIM;CLIM;GENERA-IMPLEMENTATION.LISP.285" + "SYS:CLIM;CLIM;WINDOW-PROTOCOL.LISP.76" + "SYS:CLIM;CLIM;STREAM-DEFPROTOCOLS.LISP.71" + "SYS:CLIM;CLIM;CLIM-DEFS.LISP.149" + "SYS:WINDOW;BITMAP-SCREEN.LISP.37") + + +;;--- Make DRAGGING-OUTPUT-RECORD use pixmaps when possible + + +;===================================== +#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;CLIM-DEFS.LISP.149") +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") + +(eval-when (compile load eval) + (scl:export 'clim::(with-output-to-pixmap-stream) 'clim)) + +(defmacro with-output-to-pixmap-stream ((stream) &body body) + (default-output-stream stream with-output-to-pixmap-stream) + `(flet ((with-output-to-pixmap-body (,stream) ,@body)) + (declare (dynamic-extent #'with-output-to-pixmap-body)) + (invoke-with-output-to-pixmap ,stream #'with-output-to-pixmap-body))) + + +;===================================== +#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;STREAM-DEFPROTOCOLS.LISP.71") +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") + +(eval-when (compile load eval) + (scl:export 'clim::(copy-area + allocate-pixmap deallocate-pixmap + copy-to-pixmap copy-from-pixmap + pixmap-width pixmap-height))) + +;; Replaces COPY-AREA-INTERNAL +(scl:fundefine 'copy-area-internal) +(defoperation copy-area window-mixin + ((window window-mixin) from-x from-y width height to-x to-y)) + + +;===================================== +#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;WINDOW-PROTOCOL.LISP.76") +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") + +;; This is called by output-recording-mixin's whopper on set-viewport-position*. +;; It shifts a region of the "host screen" that's visible to some other visible +;; location. It does NOT do any cleaning up after itself. It does not side-effect +;; the output history of the window. It calls COPY-AREA-INTERNAL whose contract is to +;; do the above, the whole above, and nothing but the above. +(defmethod window-shift-visible-region ((window window-mixin) + old-left old-top old-right old-bottom + new-left new-top new-right new-bottom) + (declare (fixnum new-left new-top new-right new-bottom)) + (declare (ignore old-right old-bottom new-right new-bottom)) + (let ((delta-x (the fixnum (- old-left new-left))) + (delta-y (the fixnum (- old-top new-top)))) + (multiple-value-bind (stream-width stream-height) + (window-inside-size window) + (declare (fixnum stream-width stream-height)) + (let (from-x from-y) + (cond ((and (>= delta-x 0) + (>= delta-y 0)) + ;; shifting down and to the right + (setq from-x 0 + from-y 0)) + ((and (>= delta-x 0) + (<= delta-y 0)) + ;; shifting up and to the right + (setq from-x 0 + from-y (abs delta-y))) + ((>= delta-y 0) + ;; shifting down and to the left + (setq from-x (abs delta-x) + from-y 0)) + (t + ;; shifting up and to the left + (setq from-x (abs delta-x) + from-y (abs delta-y)))) + (let ((width (the fixnum (- stream-width (abs (the fixnum delta-x))))) + (height (the fixnum (- stream-height (abs (the fixnum delta-y)))))) + (multiple-value-bind (ml mt) (window-margins window) + (declare (fixnum ml mt)) + (translate-fixnum-positions ml mt from-x from-y)) + (let ((to-x (the fixnum (+ from-x delta-x))) + (to-y (the fixnum (+ from-y delta-y)))) + (copy-area window from-x from-y width height to-x to-y))))))) + + +;;; Basic pixmaps + +(defclass basic-pixmap () + ((pixmap :initarg :pixmap) + (screen :initarg :screen) + (width :initarg :width :reader pixmap-width) + (height :initarg :height :reader pixmap-height))) + +(defmethod copy-to-pixmap ((stream encapsulating-stream-mixin) + window-x window-y width height + &optional pixmap (pixmap-x 0) (pixmap-y 0)) + (copy-to-pixmap (slot-value stream 'stream) + window-x window-y width height + pixmap pixmap-x pixmap-y)) + +(defmethod copy-from-pixmap (pixmap pixmap-x pixmap-y width height + (stream encapsulating-stream-mixin) window-x window-y) + (copy-from-pixmap pixmap pixmap-x pixmap-y width height + (slot-value stream 'stream) window-x window-y)) + + +;===================================== +#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;GENERA-IMPLEMENTATION.LISP.285") +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") + +;;; Pixmaps + +;; Replaces COPY-AREA-INTERNAL +(defmethod copy-area ((stream sheet-implementation-mixin) + from-x from-y width height to-x to-y) + ;; Coords in "host" coordinate system + (when (window-drawing-possible stream) + (fix-points from-x from-y width height to-x to-y) + (with-slots (window) stream + (when (>= to-x from-x) + ;; Shifting to the right + (setq width (- (abs width)))) + (when (>= to-y from-y) + (setq height (- (abs height)))) + (scl:send window :bitblt-within-sheet + tv:alu-seta width height from-x from-y to-x to-y)))) + + +(defclass genera-pixmap (basic-pixmap)) + +(defmethod allocate-pixmap ((stream sheet-implementation-mixin) width height) + (with-slots (window) stream + (let* ((root (window-root stream)) + (screen (slot-value root 'window)) + (pixmap (tv:allocate-bitmap-stream :for-stream window + :width width :height height + :host-allowed t))) + (make-instance 'genera-pixmap + :pixmap pixmap :screen screen + :width width :height height)))) + +(defmethod deallocate-pixmap ((pixmap genera-pixmap)) + (with-slots (pixmap) pixmap + (tv:deallocate-bitmap-stream pixmap) + (setq pixmap nil))) + +(defmethod copy-to-pixmap ((stream sheet-implementation-mixin) + window-x window-y width height + &optional pixmap (pixmap-x 0) (pixmap-y 0)) + (fix-points window-x window-y width height pixmap-x pixmap-y) + (with-slots (window) stream + (cond ((null pixmap) + (setq pixmap (allocate-pixmap stream width height))) + (t + (check-type pixmap genera-pixmap) + (let* ((root (window-root stream)) + (screen (slot-value root 'window))) + (assert (eql screen (slot-value pixmap 'screen)) () + "You can only use a pixmap on the screen for which it was allocated")))) + (scl:send (slot-value pixmap 'pixmap) :bitblt-from-sheet + tv:alu-seta width height pixmap-x pixmap-y + window window-x window-y)) + pixmap) + +(defmethod copy-from-pixmap ((pixmap genera-pixmap) pixmap-x pixmap-y width height + (stream sheet-implementation-mixin) window-x window-y) + (fix-points window-x window-y width height pixmap-x pixmap-y) + (let* ((root (window-root stream)) + (screen (slot-value root 'window))) + (assert (eql screen (slot-value pixmap 'screen)) () + "You can only use a pixmap on the screen for which it was allocated")) + (with-slots (window) stream + (scl:send (slot-value pixmap 'pixmap) :bitblt-to-sheet + tv:alu-seta width height pixmap-x pixmap-y + window window-x window-y)) + pixmap) + + +(defclass genera-pixmap-stream + (sheet-implementation-mixin window-stream) + () + (:default-initargs :display-device-type nil + :text-cursor nil)) + +(defmethod initialize-instance :after ((stream genera-pixmap-stream) &key parent pixmap) + (assert (not (null parent)) () + "You must provide a root window for Genera pixmap streams") + (with-slots (display-device-type) stream + (unless display-device-type + (setf display-device-type (slot-value parent 'display-device-type)))) + (let ((root-sheet (slot-value (window-root parent) 'window)) + (parent-sheet (slot-value parent 'window)) + (sheet (slot-value pixmap 'pixmap))) + (with-slots (left top right bottom) stream + (multiple-value-bind (width height) (scl:send parent-sheet :size) + (setf left 0 + top 0 + right width + bottom height))) + (setf (slot-value stream 'window) sheet) + (setf (slot-value stream 'color-p) (color:color-stream-p root-sheet)) + (setf (slot-value stream 'embedded-p) + (typep (tv:sheet-screen sheet) 'tv:basic-remote-screen)) + (setf (medium-foreground stream) (medium-foreground parent)) + (setf (medium-background stream) (medium-background parent)) + (associate-clim-window-with-host-window sheet stream))) + +(defmethod (setf medium-foreground) :after (ink (stream genera-pixmap-stream)) + (with-slots (window) stream + (scl:send window :set-char-aluf (sheet-decode-color ink stream nil)))) + +(defmethod (setf medium-background) :after (ink (stream genera-pixmap-stream)) + (with-slots (window) stream + (scl:send window :set-erase-aluf (sheet-decode-color ink stream nil)))) + +(defmethod invoke-with-output-to-pixmap ((stream sheet-implementation-mixin) continuation) + (let* ((pixmap (allocate-pixmap stream nil nil)) + (stream (make-instance 'genera-pixmap-stream + :parent stream :pixmap pixmap))) + (funcall continuation stream) + pixmap)) + + +;===================================== +#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;CLX-IMPLEMENTATION.LISP.236") +#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") + +;;; Pixmaps + +;; Replaces COPY-AREA-INTERNAL +(defmethod copy-area ((stream clx-window) from-x from-y width height to-x to-y) + ;; Coords in "host" coordinate system + (fix-points from-x from-y width height to-x to-y) + (with-slots (window copy-gc) stream + (xlib:copy-area window copy-gc from-x from-y width height window to-x to-y)) + (clx-force-output-if-necessary stream)) + + +(defclass clx-pixmap (basic-pixmap)) + +(defmethod allocate-pixmap ((stream clx-window) width height) + (with-slots (window) stream + (let* ((root (window-root stream)) + (screen (slot-value root 'window)) + (pixmap (xlib:create-pixmap :drawable window + :width width :height height + :depth (xlib:drawable-depth window)))) + (make-instance 'clx-pixmap + :pixmap pixmap :screen screen + :width width :height height)))) + +(defmethod deallocate-pixmap ((pixmap clx-pixmap)) + (with-slots (pixmap) pixmap + (xlib:free-pixmap pixmap) + (setq pixmap nil))) + +(defmethod copy-to-pixmap ((stream clx-window) window-x window-y width height + &optional pixmap (pixmap-x 0) (pixmap-y 0)) + (fix-points window-x window-y width height pixmap-x pixmap-y) + (with-slots (window copy-gc) stream + (cond ((null pixmap) + (setq pixmap (allocate-pixmap stream width height))) + (t + (check-type pixmap clx-pixmap) + (let* ((root (window-root stream)) + (screen (slot-value root 'window))) + (assert (eql screen (slot-value pixmap 'screen)) () + "You can only use a pixmap on the screen for which it was allocated")))) + (xlib:copy-area window copy-gc window-x window-y width height + (slot-value pixmap 'pixmap) pixmap-x pixmap-y)) + pixmap) + +(defmethod copy-from-pixmap ((pixmap clx-pixmap) pixmap-x pixmap-y width height + (stream clx-window) window-x window-y) + (fix-points window-x window-y width height pixmap-x pixmap-y) + (let* ((root (window-root stream)) + (screen (slot-value root 'window))) + (assert (eql screen (slot-value pixmap 'screen)) () + "You can only use a pixmap on the screen for which it was allocated")) + (with-slots (window copy-gc) stream + (xlib:copy-area (slot-value pixmap 'pixmap) copy-gc pixmap-x pixmap-y width height + window window-x window-y)) + (clx-force-output-if-necessary stream) + pixmap) + + +(defclass clx-pixmap-stream + (clx-window) + () + (:default-initargs :display-device-type nil + :text-cursor nil)) + +(defmethod initialize-instance :after ((stream clx-pixmap-stream) &key parent pixmap) + (assert (not (null parent)) () + "You must provide a root window for CLX pixmap streams") + (with-slots (display-device-type) stream + (unless display-device-type + (setf display-device-type (slot-value parent 'display-device-type)))) + (let ((sheet (slot-value pixmap 'pixmap))) + (with-slots (root screen window left top right bottom + color-p white-pixel black-pixel copy-gc points-to-pixels) stream + (setf root (clx-stream-root parent)) + (setf screen (clx-stream-screen parent)) + (setf window sheet) + (setf left 0) + (setf top 0) + (setf right (xlib:screen-width screen)) + (setf bottom (xlib:screen-height screen)) + (setf color-p (color-stream-p stream)) + (setf color-p (color-stream-p stream)) + (setf black-pixel (xlib:screen-black-pixel screen)) + (setf copy-gc (xlib:create-gcontext :drawable window :exposures nil)) + (setf points-to-pixels (* (sqrt (* (/ (xlib:screen-width screen) + (xlib:screen-width-in-millimeters screen)) + (/ (xlib:screen-height screen) + (xlib:screen-height-in-millimeters screen)))) + (/ 25.4s0 72))) + (let ((rounded (round points-to-pixels))) + (when (< (abs (- points-to-pixels rounded)) .1s0) + (setf points-to-pixels rounded))) + (clx-recompute-gcs stream) + (setf (getf (xlib:window-plist window) 'stream) stream))) + (setf (medium-foreground stream) (medium-foreground parent)) + (setf (medium-background stream) (medium-background parent))) + +(defmethod (setf medium-foreground) :after (ink (stream clx-pixmap-stream)) + (declare (ignore ink)) + (clx-recompute-gcs stream)) + +(defmethod (setf medium-background) :after (ink (stream clx-pixmap-stream)) + (declare (ignore ink)) + (clx-recompute-gcs stream)) + +(defmethod invoke-with-output-to-pixmap ((stream clx-window) continuation) + (let* ((pixmap (allocate-pixmap stream nil nil)) + (stream (make-instance 'clx-pixmap-stream + :parent stream :pixmap pixmap))) + (funcall continuation stream) + pixmap)) + diff --git a/pre-silica/cloe-applications.lisp b/pre-silica/cloe-applications.lisp new file mode 100644 index 00000000..33c3aa37 --- /dev/null +++ b/pre-silica/cloe-applications.lisp @@ -0,0 +1,24 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: cloe-applications.lisp,v 1.4 91/03/26 12:47:13 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(defun run-cloe-application (name) + (win::start-windows) + (unwind-protect + (progn + (win::show-window (win::get-term-window) :type :minimize) + (run-frame-top-level (make-application-frame name :parent (open-root-window :cloe)))) + (win::stop-windows))) + +(defun cloe-debugger-hook (condition hook) + (declare (ignore hook)) + (let ((term (win::get-term-window))) + (win::show-window term :type :show-normal) + (unwind-protect + (invoke-debugger condition) + (when (frame-top-level-sheet *application-frame*) + (win::show-window term :type :minimize))))) diff --git a/pre-silica/cloe-events.lisp b/pre-silica/cloe-events.lisp new file mode 100644 index 00000000..36a58bd5 --- /dev/null +++ b/pre-silica/cloe-events.lisp @@ -0,0 +1,291 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: cloe-events.lisp,v 1.4 91/03/26 12:47:14 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +(defvar *cloe-windows-with-deferred-events* nil) +(defvar *input-queued* nil) +(defvar *pointer-moved* nil) +(defvar *pointer-window*) +(defvar *pointer-x*) +(defvar *pointer-y*) + +(defun cloe-note-pointer-motion (stream x y) + (setf *pointer-window* stream) + (setf *pointer-x* x) + (setf *pointer-y* y) + (setf *pointer-moved* t)) + +(defun-inline sign-extend-16 (n) + (dpb n (byte 15 0) (- (ldb (byte 1 15) n)))) + +(defmethod cloe-vanilla-event ((stream cloe-window-stream) message args) + (declare (fixnum message)) + (with-slots (update-region pending-scrolls move-pending input-buffer + event-left event-top event-width event-height) stream + (cond ((= message win::wm_paint) + (let ((ileft (win::get-16bit args 4)) + (itop (win::get-16bit args 6)) + (iright (win::get-16bit args 8)) + (ibottom (win::get-16bit args 10))) + (unless (or (= ileft iright) (= itop ibottom)) ;seems to happen alot + (multiple-value-bind (dsx dsy) + (viewport-to-drawing-surface-coordinates stream ileft itop) + (push (make-bounding-rectangle + dsx dsy + (+ dsx (- iright ileft)) (+ dsy (- ibottom itop))) + update-region) + (pushnew stream *cloe-windows-with-deferred-events*))))) + ;; scrolling + ((or (= message win::wm_hscroll) (= message win::wm_vscroll)) + (let ((type (win::get-16bit args 4)) + (position (win::get-16bit args 6)) + (message (cond ((= message win::wm_hscroll) :x) + ((= message win::wm_vscroll) :y)))) + (declare (fixnum type position)) + (multiple-value-bind (type position) + (cond ((= type win::sb_lineup) + (values :relative-jump -1)) + ((= type win::sb_linedown) + (values :relative-jump +1)) + ((= type win::sb_pageup) + (values :screenful -1)) + ((= type win::sb_pagedown) + (values :screenful +1)) + ((= type win::sb_thumbposition) + (values :percentage position)) + ((= type win::sb_top) + (values :percentage 0)) + ((= type win::sb_bottom) + (values :percentage 100))) + (when type + (queue-put pending-scrolls (list message type position)) + (pushnew stream *cloe-windows-with-deferred-events*))))) + ;; resizing + ((= message win::wm_move) + (setf event-left (sign-extend-16 (win::get-16bit args 6))) + (setf event-top (sign-extend-16 (win::get-16bit args 8))) + (pushnew stream *cloe-windows-with-deferred-events*) + (setf move-pending t)) + ((= message win::wm_size) + (unless (= (the fixnum (win::get-16bit args 4)) win::sizeiconic) + (setf event-width (win::get-16bit args 6)) + (setf event-height (win::get-16bit args 8)) + (pushnew stream *cloe-windows-with-deferred-events*) + (setf move-pending t))) + ;; character typed + ((= message win::wm_char) + (let ((char (aref args 4))) + (when (char= char #\return) + (setq char #\newline)) + (queue-put input-buffer char)) + (setf *input-queued* t)) + ;; meta character typed + ((= message win::wm_syschar) ;meta key + (let ((char (set-char-bit + (char-upcase (aref args 4)) :meta t))) + (queue-put input-buffer char)) + (setf *input-queued* t)) + ;; button press or release + ((or (= message win::wm_lbuttondown) + (= message win::wm_rbuttondown) + (= message win::wm_mbuttondown) + (= message win::wm_lbuttonup) + (= message win::wm_rbuttonup) + (= message win::wm_mbuttonup)) + (let ((mask (win::get-16bit args 4)) + (x (win::get-16bit args 6)) + (y (win::get-16bit args 8)) + (pointer (stream-primary-pointer stream))) + (cloe-note-pointer-motion stream x y) + (when pointer + (cond ((or (= message win::wm_lbuttondown) + (= message win::wm_rbuttondown) + (= message win::wm_mbuttondown)) + (stream-note-pointer-button-press + stream pointer (case message + (#.win::wm_lbuttondown 1) + (#.win::wm_mbuttondown 2) + (#.win::wm_rbuttondown 4)) + (windows-mask->modifier-state mask) x y) + (setf *input-queued* t)) + (*generate-button-release-events* + (stream-note-pointer-button-release + stream pointer (case message + (#.win::wm_lbuttonup 1) + (#.win::wm_mbuttonup 2) + (#.win::wm_rbuttonup 4)) + (windows-mask->modifier-state mask) x y) + (setf *input-queued* t))))))))) + +(defun win::vanilla-event (code length args) + (declare (ignore length)) ;because I don't know what they are! + (let ((stream (clim-window-for-host-window + (win::get-16bit args 0) :error-if-no-match nil)) + (message (win::get-16bit args 2))) + (declare (fixnum message)) + (when stream + (cond ((= message win::wm_mousemove) + (let ((x (win::get-16bit args 6)) + (y (win::get-16bit args 8))) + (cloe-note-pointer-motion stream x y))) + (t + (cloe-vanilla-event stream message args)))))) + +;;; Convert a MS Windows shift mask into a CLIM modifier-state +(defun windows-mask->modifier-state (mask) + (let ((modifier-state 0)) + (macrolet ((do-shift (shift) + `(when (logtest ,(intern (format nil "MK_~A" (symbol-name shift)) + (find-package 'win)) + mask) + (let ((bit (modifier-key-index ,shift))) + (setf modifier-state (dpb 1 (byte 1 bit) modifier-state)))))) + (do-shift :shift) + (do-shift :control) + ;; no meta super or hyper bits here! + modifier-state + ))) + +(defmethod set-pointer-window-and-location ((stream cloe-window-stream) pointer) + ;;--- What should this do? + ) + +(defmethod stream-event-handler ((stream cloe-window-stream) + &key (timeout nil) (input-wait-test nil)) + (cloe-event-handler timeout input-wait-test stream)) + +(defmethod stream-event-handler ((stream cloe-root-window) + &key (timeout nil) (input-wait-test nil)) + (cloe-event-handler timeout input-wait-test stream)) + +(defun cloe-event-handler (timeout input-wait-test original-stream) + (cloe-process-all-deferred-events) + (let ((end-time (and timeout (+ (get-internal-real-time) + (* internal-time-units-per-second timeout)))) + ;; If we're inside an encapsulating stream, such as the input editor, and a window + ;; resizing event is received, don't get confused while handling the event + (*original-stream* nil)) + (loop + ;; The assumption is that the input-wait-test function can only change + ;; its value when an event is received and processed. The only + ;; commonly-desired exception is a timeout, which we provide directly. + (when (and input-wait-test (funcall input-wait-test original-stream)) + (return-from cloe-event-handler :input-wait-test)) + (win::await-response -1 nil t) + ;; we do this here, rather than in vanilla event + ;; to provide for better synchronization. + (cloe-process-all-deferred-events) + (when *pointer-moved* + (setf *pointer-moved* nil) + (let ((window *pointer-window*)) + (setf (pointer-window *cloe-pointer*) window) + (when window + (multiple-value-bind (wx wy) + (window-offset window) + (pointer-set-position* *cloe-pointer* (+ *pointer-x* wx) (+ *pointer-y* wy))) + (setf (pointer-motion-pending window *cloe-pointer*) t))) + (return :mouse-motion)) + (when *input-queued* + (setf *input-queued* nil) + (return :input-buffer)) + (when (and end-time (> (get-internal-real-time) end-time)) + (return :timeout))))) + +;;; Called after paint events have likely been generated. First, make sure +;;; they get read from the WINFE side. Then, process all queued paint events +;;; now. +(defun handle-generated-paints () + (win::await-response -1 nil nil) + (cloe-process-all-deferred-events)) + +(defmethod set-stream-pointer-in-screen-coordinates ((stream cloe-window-stream) + pointer x y) + (declare (ignore pointer)) + (win::set-pointer-position x y)) + +(defmethod stream-pointer-input-rectangle* + ((stream cloe-window-stream) + pointer &key left top right bottom) + (declare (ignore left top right bottom)) + (portable-pointer-input-rectangle* stream pointer)) + +(defun cloe-process-all-deferred-events () + (loop + (when (null *cloe-windows-with-deferred-events*) (return)) + (cloe-process-deferred-events (pop *cloe-windows-with-deferred-events*)))) + +(defmethod cloe-process-deferred-events ((stream cloe-window-stream)) + (with-slots (window left top right bottom margin-width margin-height + event-left event-top event-width event-height + move-pending update-region pending-scrolls) stream + (declare (fixnum left top right bottom event-left event-top event-width event-height)) + (when move-pending + (setf move-pending nil) + (unless (win::is-iconic window) + (multiple-value-bind (new-left new-top new-right new-bottom) + (multiple-value-bind (width height) + (multiple-value-bind (wleft wtop wright wbottom) + (win::get-window-rectangle window) + (declare (fixnum wleft wtop wright wbottom)) + (values (- wright wleft) (- wbottom wtop))) + (declare (fixnum width height)) + (setf margin-width (- width event-width)) + (setf margin-height (- height event-height)) + (values event-left event-top (+ event-left width) (+ event-top height))) + (declare (fixnum new-left new-top new-right new-bottom)) + (unless (and (= left new-left) (= top new-top) + (= right new-right) (= bottom new-bottom)) + (window-note-size-or-position-change + stream new-left new-top new-right new-bottom))))) + (loop + (let ((entry (queue-get pending-scrolls))) + (when (null entry) (return)) + (apply #'cloe-process-deferred-scroll stream entry))) + (when update-region + (window-process-update-region stream)) + nil)) + +(defmethod cloe-process-deferred-scroll ((stream cloe-window-stream) message type position) + (multiple-value-bind (new-left new-top) + (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream) + (multiple-value-bind (hleft htop hright hbottom) + (let ((history (and (output-recording-stream-p stream) + (stream-output-history stream)))) + (if history + (bounding-rectangle* history) + (values 0 0 1000 100))) + (ecase message + (:y + (values vleft + (min (max htop + (ecase type + (:relative-jump + (+ vtop (* position (stream-line-height stream)))) + (:screenful + (+ vtop (* position (- vbottom vtop)))) + (:percentage + (+ htop + (round (* position (- (- hbottom htop) (- vbottom vtop))) + 100))))) + hbottom))) + (:x + (values (min (max hleft + (ecase type + (:relative-jump + (+ vleft + (* position (stream-character-width stream #\space)))) + (:screenful + (+ vleft (* position (- vright vleft)))) + (:percentage + (+ hleft + (round (* position (- (- hright hleft) (- vright vleft))) + 100))))) + hright) + vtop)) + ))) + (window-set-viewport-position* stream new-left new-top))) diff --git a/pre-silica/cloe-implementation.lisp b/pre-silica/cloe-implementation.lisp new file mode 100644 index 00000000..9839b4c3 --- /dev/null +++ b/pre-silica/cloe-implementation.lisp @@ -0,0 +1,1035 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: cloe-implementation.lisp,v 1.4 91/03/26 12:47:15 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +;;; Support for the shared class DC. + +(defvar *dc*) + +(defvar *current-pen*) +(defvar *current-brush*) +(defvar *current-rop2*) +(defvar *current-background-color*) +(defvar *current-text-color*) +(defvar *current-font*) + +;;; Stock objects + +(defvar *null-pen*) +(defvar *black-pen*) +(defvar *white-pen*) + +(defvar *null-brush*) +(defvar *black-brush*) +(defvar *white-brush*) + +;;; Original objects + +(defvar *color-to-image* (make-hash-table)) +(defvar *black-image*) +(defvar *white-image*) + +(defvar *ink-to-image* (make-hash-table)) + +(defstruct (dc-image (:predicate nil)) + (bitmap nil) + solid-1-pen + (pen-table (make-hash-table)) + brush + (rop2 win::r2_copypen) + text-color + background-color) + +;;; + +(defun initialize-dc () + ;; Dummy window to represent class. + (setf *dc* (win::create-window "Vanilla" "CLIM" win::ws_popup 0 0 0 0 0 0 0 "arg")) + + ;; Stock objects + (setf *null-pen* (win::get-stock-object win::null_pen)) + (setf *black-pen* (win::get-stock-object win::black_pen)) + (setf *white-pen* (win::get-stock-object win::white_pen)) + (setf *current-pen* *black-pen*) + + (setf *null-brush* (win::get-stock-object win::null_brush)) + (setf *black-brush* (win::get-stock-object win::black_brush)) + (setf *white-brush* (win::get-stock-object win::white_brush)) + (setf *current-brush* *white-brush*) + + (setf *current-rop2* win::r2_copypen) + (setf *current-background-color* #xffffff) + (setf *current-text-color* #x000000) + (setf *current-font* nil) + + (setf *black-image* + (make-dc-image :solid-1-pen *black-pen* :brush *black-brush* + :text-color #x000000 :background-color nil)) + (setf (gethash #x000000 *color-to-image*) *black-image*) + (setf *white-image* + (make-dc-image :solid-1-pen *white-pen* :brush *white-brush* + :text-color #xffffff :background-color nil)) + (setf (gethash #xffffff *color-to-image*) *white-image*) + ) + +(defun select-pen (pen) + (unless (eql *current-pen* pen) + (win::select-pen *dc* pen) + (setf *current-pen* pen)) + pen) + +(defun select-brush (brush) + (unless (eql *current-brush* brush) + (win::select-brush *dc* brush) + (setf *current-brush* brush)) + brush) + +(defun select-rop2 (rop2) + (unless (eql *current-rop2* rop2) + (win::set-rop2 *dc* rop2) + (setf *current-rop2* rop2)) + rop2) + +(defun select-background-color (color) + (unless (eql *current-background-color* color) + (cond ((null color) + #||(win::set-background-mode *dc* win::transparent)||#) + (t + #||(when (null *current-background-color*) + (win::set-background-mode *dc* win::opaque))||# + (win::set-background-color *dc* color) + (setf *current-background-color* color)))) + color) + +(defun select-text-color (color) + (unless (eql *current-text-color* color) + (win::set-text-color *dc* color) + (setf *current-text-color* color)) + color) + +(defun select-font (font) + (unless (eql *current-font* font) + (win::select-font *dc* font) + (setf *current-font* font)) + font) + +;;; + +(defun set-dc-for-drawing (image line-style) + (let ((dashes (line-style-dashes line-style))) + (select-pen + (let* ((thickness (max 1 (round (line-style-thickness line-style)))) + (code (if dashes (- thickness) thickness))) + (declare (fixnum thickness code)) + (if (= code 1) + (dc-image-solid-1-pen image) + (or (gethash code (dc-image-pen-table image)) + (setf (gethash code (dc-image-pen-table image)) + (win::create-pen (if dashes win::ps_dash win::ps_solid) + thickness + (dc-image-text-color image))))))) + (when dashes + (select-background-color nil))) + (select-brush *null-brush*) + (select-rop2 (dc-image-rop2 image)) + image) + +(defun set-dc-for-filling (image) + (select-pen *null-pen*) + (select-brush (dc-image-brush image)) + (let ((background-color (dc-image-background-color image))) + (when background-color + (select-background-color background-color))) + (select-rop2 (dc-image-rop2 image))) + +(defun set-dc-for-ink (stream ink line-style) + (let ((image (dc-image-for-ink stream ink))) + (if line-style + (set-dc-for-drawing image line-style) + (set-dc-for-filling image)))) + +(defun set-dc-for-text (stream ink font) + (select-text-color (dc-image-text-color (dc-image-for-ink stream ink))) + (select-background-color nil) + (select-font font)) + + + +(defclass cloe-root-window + (window-stream) + () + (:default-initargs :input-buffer nil :display-device-type *cloe-device* :left 0 :top 0)) + +(defmethod initialize-instance :after ((stream cloe-root-window) &key) + (unless win::*windows-enabled* + (win::start-windows)) + (with-slots (right bottom) stream + (multiple-value-setq (right bottom) + (win::get-screen-size))) + (initialize-dc) + (setf (stream-pointers stream) (list (make-instance 'standard-pointer :root stream)))) + +(defmethod window-margins ((stream cloe-root-window)) + (values 0 0 0 0)) + +(defmethod host-window-margins ((stream cloe-root-window)) + (values 0 0 0 0)) + +(defmethod window-stream-class-name ((stream cloe-root-window)) + 'cloe-window-stream) + +(defmethod close ((stream cloe-root-window) &key abort) + (declare (ignore abort)) + nil) + +(defvar *cloe-root-window*) +(defvar *cloe-pointer*) + +(defun create-cloe-root-window () + (unless (boundp '*cloe-root-window*) + (setf *cloe-root-window* (make-instance 'cloe-root-window)) + (setf *cloe-pointer* (stream-primary-pointer *cloe-root-window*))) + *cloe-root-window*) + +(define-implementation :cloe 'create-cloe-root-window) + + + +(defclass cloe-window-stream + (window-stream) + ((window :initarg :window) + (move-pending :initform nil) + (event-width) (event-height) + (event-left) (event-top) + (margin-width) (margin-height) + (h-scroll-pos :initform nil) + (v-scroll-pos :initform nil) + (pending-scrolls :initform (make-queue)) + (background-dc-image) + (foreground-dc-image) + (modifier-state :initform 0 :reader window-modifier-state)) + (:default-initargs :display-device-type *cloe-device*)) + +(defmethod initialize-instance :after ((stream cloe-window-stream) &key parent + label (scroll-bars :both) (borders t) save-under) + (with-slots (window left top right bottom margin-width margin-height + event-left event-top event-width event-height + foreground-dc-image background-dc-image) + stream + (let ((top-level (not (slot-exists-p parent 'window)))) + (setf window (win::create-window + "Vanilla" (or label "CLIM") + (logior win::ws_clipchildren ;new, helps refresh + (if top-level + (if save-under + (logior win::ws_popup + win::ws_border) + (logior win::ws_overlapped + win::ws_caption + win::ws_thickframe + win::ws_sysmenu + win::ws_minimizebox + win::ws_maximizebox)) + (logior win::ws_child + win::ws_clipsiblings + (if borders win::ws_border 0))) + (if (member scroll-bars '(:horizontal :both)) + (progn (setf h-scroll-pos 0) + win::ws_hscroll) + 0) + (if (member scroll-bars '(:vertical :both)) + (progn (setf v-scroll-pos 0) + win::ws_vscroll) + 0) + ) + left top (- right left) (- bottom top) + (if top-level 0 (slot-value parent 'window)) 0 0 "arg"))) + (associate-clim-window-with-host-window window stream) + (setf foreground-dc-image (dc-image-for-ink stream (medium-foreground stream))) + (setf background-dc-image (dc-image-for-ink stream (medium-background stream))) + (multiple-value-bind (cleft ctop cright cbottom) + (win::get-client-rectangle window) + (multiple-value-bind (wleft wtop wright wbottom) + (win::get-window-rectangle window) + (setf margin-width (- (- wright wleft) (- cright cleft))) + (setf margin-height (- (- wbottom wtop) (- cbottom ctop)))) + (setf event-left (+ left cleft)) + (setf event-top (+ top ctop)) + (setf event-width (- cright cleft)) + (setf event-height (- cbottom ctop)) + (setf right (+ left event-width margin-width)) + (setf bottom (+ top event-height margin-height))) + nil)) + +(defmethod (setf window-label) :after (new-label (stream cloe-window-stream)) + (when (consp new-label) + (setf new-label (first new-label))) + (with-slots (window) stream + (win::set-window-text window (or new-label "CLIM")))) + +(defmethod implementation-pixels-per-point ((stream cloe-window-stream)) + 1) + +(defmethod window-beep ((stream cloe-window-stream)) + (win::message-beep)) + +(defmethod close ((stream cloe-window-stream) &key abort) + (declare (ignore abort)) + (with-slots (window) stream + (win::destroy-window window))) + +;;; After changing the background color, refresh the window. +(defmethod (setf medium-background) :after (new-background (stream cloe-window-stream)) + (with-slots (background-dc-image) stream + (setf background-dc-image (dc-image-for-ink stream new-background))) + (window-refresh stream)) + +(defmethod (setf medium-foreground) :after (new-foreground (stream cloe-window-stream)) + (with-slots (foreground-dc-image) stream + (setf foreground-dc-image (dc-image-for-ink stream new-foreground))) + (window-refresh stream)) + +(defmethod window-erase-viewport ((stream cloe-window-stream)) + (when (window-drawing-possible stream) + (multiple-value-bind (width height) + (window-inside-size stream) + (window-clear-area stream 0 0 width height)))) + +(defmethod (setf window-visibility) :after (visibility (stream cloe-window-stream)) + (labels ((window-set-visibility-1 (stream visibility) + (win::show-window (slot-value stream 'window) + :type (if visibility :show-no-activate :hide)) + (dolist (child (window-children stream)) + (when (window-visibility child) + (window-set-visibility-1 child visibility))))) + (window-set-visibility-1 stream visibility)) + (handle-generated-paints) + visibility) + + (defmethod wait-for-window-exposed ((window cloe-window-stream)) + (loop + (when (window-visibility window) + (return)) + (process-yield))) + +(defmethod window-drawing-possible ((stream cloe-window-stream)) + (window-visibility stream)) + +(defmethod window-stack-on-top ((stream cloe-window-stream)) + (with-slots (window) stream + (win::set-window-position window 0 0 0 0 0 + (logior win::swp_noactivate + win::swp_nomove + win::swp_nosize))) + (handle-generated-paints)) + +(defmethod window-stack-on-bottom ((stream cloe-window-stream)) + (with-slots (window) stream + (win::set-window-position window 1 0 0 0 0 + (logior win::swp_noactivate + win::swp_nomove + win::swp_nosize))) + (handle-generated-paints)) + +(defmethod bounding-rectangle-set-edges :after + ((stream cloe-window-stream) left top right bottom) + (with-slots (window) stream + (win::move-window window left top (- right left) (- bottom top) t)) + (handle-generated-paints)) + +(defmethod bounding-rectangle-set-position* :after + ((stream cloe-window-stream) new-left new-top) + (multiple-value-bind (width height) (bounding-rectangle-size stream) + (with-slots (window) stream + (win::move-window window new-left new-top width height t))) + (handle-generated-paints)) + +(defmethod bounding-rectangle-set-size :after + ((stream cloe-window-stream) width height) + (multiple-value-bind (left top) (bounding-rectangle-position* stream) + (with-slots (window) stream + (win::move-window window left top width height t))) + (handle-generated-paints)) + +(defmethod stream-force-output ((stream cloe-window-stream)) + (declare (ignore stream)) + ) + +(defmethod stream-clear-output ((stream cloe-window-stream)) + (declare (ignore stream)) + ) + +(defmethod stream-finish-output ((stream cloe-window-stream)) + (declare (ignore stream)) + ) + +(defmethod window-margins ((stream cloe-window-stream)) + (declare (ignore stream)) + (values 0 0 0 0)) + +(defmethod host-window-margins ((stream cloe-window-stream)) + (with-slots (margin-width margin-height) stream + (values 0 0 margin-width margin-height))) + +(defmethod window-flush-update-region ((stream cloe-window-stream)) + (with-slots (update-region) stream + (setf update-region nil))) + +;;;changed to fix the scrolling problem +(defmethod window-process-update-region ((stream cloe-window-stream)) + (with-slots (window update-region background-dc-image) stream + (when update-region + (set-dc-for-filling background-dc-image) + (multiple-value-bind (dx dy) + (window-viewport-position* stream) + (declare (type coordinate dx dy)) + (dolist (region update-region) + (with-bounding-rectangle* (left top right bottom) region + (win::rectangle window (- left dx) (- top dy) + (- right dx) (- bottom dy)))))))) + +;;; Postpone better update region stuff. +(defmethod window-shift-visible-region :after ((stream cloe-window-stream) + old-left old-top old-right old-bottom + new-left new-top new-right new-bottom) + + (setf (slot-value stream 'update-region) + (ltrb-difference new-left new-top new-right new-bottom + old-left old-top old-right old-bottom))) + +;; Does this want to be an :after method? Will the primary method on +;; window-stream ever want to do anything else? +(defmethod stream-set-input-focus ((stream cloe-window-stream)) + (with-slots (window) stream + (win::set-focus window))) + +(defmethod stream-restore-input-focus ((stream cloe-window-stream) old-focus) + (declare (ignore stream)) + (win::set-focus old-focus)) + +(defmethod stream-has-input-focus ((stream cloe-window-stream)) + (with-slots (window) stream + (= window (win::get-focus)))) + +(defmethod notify-user-1 ((stream cloe-window-stream) frame format-string &rest format-args) + (declare (ignore frame) (dynamic-extent format-args)) + (let ((formatted-string (apply #'format nil format-string format-args))) + (clos:with-slots (window) stream + (win::notify-user window formatted-string)))) + +;;; Draw a rectangle in the background color. +(defmethod window-clear-area ((stream cloe-window-stream) left top right bottom) + (with-slots (window background-dc-image) stream + (set-dc-for-filling background-dc-image) + (win::rectangle window left top right bottom))) + +(defmethod copy-area ((stream cloe-window-stream) + from-left from-top from-right from-bottom + to-left to-top) + (fix-points from-left from-top from-right from-bottom to-left to-top) + (let ((x-delta (- to-left from-left)) ; can be negative + (y-delta (- to-top from-top))) ; can be negative + (multiple-value-bind (width height) + (window-inside-size stream) + (with-slots (window) stream + (win::scroll-dc window + x-delta y-delta + from-left from-top + ;; --- from-bottom or 1+? + from-right from-bottom ;rectangles are different... + 0 0 width height))))) + +;;; Scrolling support. +(defmethod cloe-recompute-scroll-bars ((stream cloe-window-stream)) + ;; don't update the scroll bars if they didn't change. + (multiple-value-bind (new-h-pos new-v-pos) + (let ((history (and (output-recording-stream-p stream) + (stream-output-history stream)))) + (when history + (multiple-value-bind (width height) (bounding-rectangle-size history) + (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream) + (values (and (< (- vright vleft) width) + (round (* vleft 100) + (- width (- vright vleft)))) + (and (< (- vbottom vtop) height) + (round (* vtop 100) + (- height (- vbottom vtop))))))))) + (with-slots (window h-scroll-pos v-scroll-pos) stream + (unless (eql new-h-pos h-scroll-pos) + (cond ((null new-h-pos) + ;;(win::show-scroll-bar window win::sb_horz nil) + (win::set-scroll-position window win::sb_horz new-h-pos)) + (t + (win::set-scroll-position window win::sb_horz new-h-pos) + #||(when (null h-scroll-pos) + (win::show-scroll-bar window win::sb_horz t))||#)) + (setf h-scroll-pos new-h-pos)) + (unless (eql new-v-pos v-scroll-pos) + (cond ((null new-v-pos) + ;;(win::show-scroll-bar window win::sb_vert nil) + (win::set-scroll-position window win::sb_vert new-v-pos)) + (t + (win::set-scroll-position window win::sb_vert new-v-pos) + #||(when (null v-scroll-pos) + (win::show-scroll-bar window win::sb_vert t))||#)) + (setf v-scroll-pos new-v-pos))))) + +(defmethod window-set-viewport-position* :after ((stream cloe-window-stream) new-x new-y) + (cloe-recompute-scroll-bars stream)) + + + +(defmethod invoke-with-clipping-region ((stream cloe-window-stream) continuation region) + (funcall continuation stream)) + +(defmethod draw-point-internal ((stream cloe-window-stream) + x-offset y-offset x y ink line-style) + (with-slots (window) stream + (fix-points x y) + (translate-positions x-offset y-offset x y) + (set-dc-for-ink stream ink line-style) + (win::rectangle window x y x y))) + +(defmethod draw-line-internal ((stream cloe-window-stream) x-offset y-offset + start-x start-y end-x end-y ink line-style) + (with-slots (window) stream + (fix-points start-x start-y end-x end-y) + (translate-positions x-offset y-offset start-x start-y end-x end-y) + (set-dc-for-ink stream ink line-style) + (win::move-to window start-x start-y) + (win::line-to window end-x end-y))) + +(defmethod draw-rectangle-internal ((stream cloe-window-stream) x-offset y-offset + left top right bottom ink line-style) + (with-slots (window) stream + (fix-points left top right bottom) + (translate-positions x-offset y-offset left top right bottom) + (set-dc-for-ink stream ink line-style) + (win::rectangle window left top right bottom))) + +(defmethod draw-polygon-internal ((stream cloe-window-stream) x-offset y-offset + list-of-x-and-ys closed ink line-style) + (with-slots (window) stream + (set-dc-for-ink stream ink line-style) + (if (null line-style) + (win::polygon window list-of-x-and-ys x-offset y-offset) + (win::polyline window list-of-x-and-ys closed x-offset y-offset)))) + +(defvar *ft* .0001) +(defun fl-= (x y) + (< (abs (- x y)) *ft*)) + +(defmethod draw-ellipse-internal ((stream cloe-window-stream) x-offset y-offset + center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) + (fix-points center-x center-y) + (translate-positions x-offset y-offset center-x center-y) + (when (null start-angle) + (setq start-angle 0.0 + end-angle 2pi)) + (with-slots (window) stream + (set-dc-for-ink stream ink line-style) + (setf radius-1-dx (round radius-1-dx)) + (setf radius-1-dy (round radius-1-dy)) + (setf radius-2-dx (round radius-2-dx)) + (setf radius-2-dy (round radius-2-dy)) + (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 (nyi))) + (let (left top right bottom) + (setq left (- center-x x-radius) + right (+ center-x x-radius) + top (- center-y y-radius) + bottom (+ center-y y-radius)) + (cond ((or (fl-= (- end-angle start-angle) 2pi) + (fl-= (- end-angle start-angle) 0)) + #+Ignore + (and (= start-angle 0) + (= end-angle 2pi)) + ;; drawing a full ellipse + (win::ellipse window left top right bottom)) + ((null line-style) + ;; drawing a pie slice + (win::pie window left top right bottom + (round (+ (* (cos end-angle) x-radius) center-x)) + (round (+ (* (sin end-angle) y-radius) center-y)) + (round (+ (* (cos start-angle) x-radius) center-x)) + (round (+ (* (sin start-angle) y-radius) center-y)) + + )) + (t + ;; drawing an arc + (win::arc window left top right bottom + (+ (* (cos start-angle) x-radius) center-x) + (+ (* (sin start-angle) y-radius) center-y) + (+ (* (cos end-angle) x-radius) center-x) + (+ (* (sin end-angle) y-radius) center-y)))))))) + + + +(defgeneric dc-image-for-ink (stream ink)) + +(defmethod dc-image-for-ink (stream (ink (eql +foreground-ink+))) + (slot-value stream 'foreground-dc-image)) + +(defmethod dc-image-for-ink (stream (ink (eql +background-ink+))) + (slot-value stream 'background-dc-image)) + +(defmethod dc-image-for-ink (stream (ink (eql +black+))) + (declare (ignore stream)) + *black-image*) + +(defmethod dc-image-for-ink (stream (ink (eql +white+))) + (declare (ignore stream)) + *white-image*) + +(defmethod dc-image-for-ink (stream (ink color)) + (declare (ignore stream)) + (multiple-value-bind (red green blue) + (color-rgb ink) + (let ((color (dpb (round (* 255 blue)) (byte 8 16) + (dpb (round (* 255 green)) (byte 8 8) + (round (* 255 red)))))) + (declare (fixnum color)) + (case color + ((#x000000) *black-image*) + ((#xffffff) *white-image*) + (otherwise + (or (gethash color *color-to-image*) + (setf (gethash color *color-to-image*) + (make-dc-image :solid-1-pen (win::create-pen win::ps_solid 1 color) + :brush (win::create-solid-brush color) + :text-color color :background-color nil)))))))) + +(defmethod dc-image-for-ink (stream (ink rectangular-tile)) + ;; The only case we handle right now is stipples + (or (gethash ink *ink-to-image*) + (setf (gethash ink *ink-to-image*) + (multiple-value-bind (array width height) + (decode-tile-as-stipple ink) + (unless array + (error "Rectangular tiles other than stipples are not supported yet.")) + (let ((into (make-array 8 :element-type '(unsigned-byte 16))) + (dc-image (copy-dc-image (slot-value stream 'foreground-dc-image)))) + (macrolet ((collect-byte (row-no) + `(let ((result 0)) + (dotimes (j 8) + (setq result + (dpb (aref array (mod ,row-no width) (mod j height)) + (byte 1 (- 7 j)) result))) + (logxor result #2r11111111)))) + (dotimes (i 8) + (setf (aref into i) (collect-byte i)))) + (let ((bitmap (win::create-bitmap into))) + (setf (dc-image-bitmap dc-image) bitmap) + (setf (dc-image-brush dc-image) (win::create-pattern-brush bitmap)) + (setf (dc-image-background-color dc-image) + (dc-image-text-color (slot-value stream 'background-dc-image)))) + dc-image))))) + +(defmethod dc-image-for-ink (stream (ink flipping-ink)) + (declare (ignore stream)) + (or (gethash ink *ink-to-image*) + (setf (gethash ink *ink-to-image*) + (multiple-value-bind (ink1 ink2) + (decode-flipping-ink ink) + (let* ((image1 (dc-image-for-ink stream ink1)) + (image2 (dc-image-for-ink stream ink2)) + (color (logxor (dc-image-text-color image1) + (dc-image-text-color image2)))) + (unless (and (eql (dc-image-rop2 image1) win::r2_copypen) + (eql (dc-image-rop2 image2) win::r2_copypen) + (null (dc-image-bitmap image1)) + (null (dc-image-bitmap image2))) + (nyi)) + (make-dc-image :solid-1-pen (win::create-pen win::ps_solid 1 color) + :brush (win::create-solid-brush color) + :rop2 win::r2_xorpen + :text-color color :background-color nil)))))) + +(defmethod dc-image-for-ink (stream (ink contrasting-ink)) + (dc-image-for-ink stream (make-color-for-contrasting-ink ink))) + + + +(defstruct (cloe-font) + index + height + ascent + descent + internal-leading + external-leading + average-character-width + maximum-character-width + weight + italic + underlined + struckout + first-character + last-character + default-character + break-character + character-set + overhang + pitch + family + font-width-table) + +;;; Fill up the font width table for a variable width font +;;; by asking windows the width of each character. +;;; This doesn't quite work in the face of kerning. +(defun initialize-font-width-table (font window) + ;; only need to run this on variable-width fonts. + (select-font (cloe-font-index font)) + (let ((array (make-array (1+ (- 126 32))))) + (with-temporary-string (string :length 1) + (setf (fill-pointer string) 1) + (loop for i from 32 to 126 do + (setf (aref string 0) (code-char i)) + (multiple-value-bind (width height) + (win::get-text-extent window string) + (declare (ignore height )) + (setf (aref array (- i 32)) width)))) + (setf (cloe-font-font-width-table font) array))) + +(defmethod stream-glyph-for-character ((stream cloe-window-stream) character style + &optional our-font) + (let ((display-device-type (slot-value stream 'display-device-type)) + (window (slot-value stream 'window))) + (multiple-value-bind (character-set index) + (char-character-set-and-index character) + (let* ((cloe-font (or our-font + (text-style-mapping + display-device-type character-set style window))) + (origin-x 0) + (origin-y (cloe-font-ascent cloe-font)) + (average-w (cloe-font-average-character-width cloe-font)) + (max-w (cloe-font-maximum-character-width cloe-font)) + (fixed-width-p (= max-w average-w)) + (escapement-x (if fixed-width-p + average-w + (aref (cloe-font-font-width-table cloe-font) (- index 32)))) + (escapement-y 0) + (bb-y (+ (cloe-font-height cloe-font) + (cloe-font-external-leading cloe-font))) + (bb-x escapement-x)) + (values index cloe-font escapement-x escapement-y + origin-x origin-y bb-x bb-y + fixed-width-p))))) + +;;; Really want to set the text color to color. Talk to Bob. +(defmethod stream-write-string-1 ((stream cloe-window-stream) + glyph-buffer start end font ink x y) + (with-slots (window) stream + (set-dc-for-text stream ink (cloe-font-index font)) + (with-temporary-string (string :length (- end start)) + (dovector (index glyph-buffer :start start :end end) + (vector-push (int-char index) string)) + (win::text-out window x y string)))) + +(defmethod stream-write-char-1 ((stream cloe-window-stream) index font ink x y) + (with-slots (window) stream + (set-dc-for-text stream ink (cloe-font-index font)) + (with-temporary-string (string :length 1) + (vector-push (int-char index) string) + (win::text-out window x y string)))) + +(defmethod draw-string-internal ((stream cloe-window-stream) + x-offset y-offset string x y + start end align-x align-y text-style ink) + (unless end (setq end (length string))) + (fix-points x y) + (translate-positions x-offset y-offset x y) + (with-temporary-substring (substring string start end) + (with-slots (window display-device-type) stream + (let* ((font (text-style-mapping + display-device-type *standard-character-set* text-style window)) + (height (cloe-font-height font)) + (descent (cloe-font-descent font)) + (ascent (cloe-font-ascent font))) + (incf x (compute-text-x-adjustment + align-x stream string text-style start end)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + (decf y ascent) ;text is positioned by its top left on CLOE + (set-dc-for-text stream ink (cloe-font-index font)) + (win::text-out window x y substring))))) + +(defmethod draw-character-internal ((stream cloe-window-stream) x-offset y-offset + character x y align-x align-y text-style ink) + (fix-points x y) + (translate-positions x-offset y-offset x y) + (with-slots (window display-device-type) stream + (let* ((font (text-style-mapping + display-device-type *standard-character-set* text-style window)) + (height (cloe-font-height font)) + (descent (cloe-font-descent font)) + (ascent (cloe-font-ascent font))) + (incf x (compute-text-x-adjustment + align-x stream character text-style)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + (decf y ascent) ;text is positioned by its top left on CLOE + (set-dc-for-text stream ink (cloe-font-index font)) + (with-temporary-string (string :length 1) + (vector-push character string) + (win::text-out window x y string))))) + + +(defmethod text-style-height ((text-style standard-text-style) (stream cloe-window-stream)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (cloe-font-height font)))) + +(defmethod text-style-width ((text-style standard-text-style) (stream cloe-window-stream)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (cloe-font-average-character-width font)))) + +(defmethod text-style-ascent ((text-style standard-text-style) (stream cloe-window-stream)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (cloe-font-ascent font)))) + +(defmethod text-style-descent ((text-style standard-text-style) (stream cloe-window-stream)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (cloe-font-descent font)))) + +(defmethod text-style-fixed-width-p ((text-style standard-text-style) (stream cloe-window-stream)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + ;; Really disgusting, but probably OK + (= (cloe-font-average-character-width font) + (cloe-font-maximum-character-width font))))) + +(defmethod text-size ((stream cloe-window-stream) string + &key (text-style (stream-merged-text-style stream)) (start 0) end) + (when (characterp string) + (setq string (string string) + start 0 + end nil)) + (multiple-value-bind (last-x largest-x last-y total-height baseline) + (stream-string-output-size stream string :text-style text-style :start start :end end) + (values largest-x total-height last-x last-y baseline))) + + +(defclass cloe-device (display-device) + ((font->cloe-font-mapping :initform (make-hash-table)))) + +(defmethod text-style-mapping :around + ((device cloe-device) character-set style &optional window) + (let ((font-name (call-next-method)) + (hash-table (slot-value device 'font->cloe-font-mapping))) + (or (gethash font-name hash-table) + (setf (gethash font-name hash-table) + (let ((name (string font-name)) + (here 0)) + (labels ((token () + (unless here (error "Ran off end of name in font parser: ~A" name)) + (let ((new-here (position #\- name :test #'char-equal :start here))) + (prog1 (subseq name here new-here) + (setf here (and new-here (1+ new-here)))))) + (integer () + (parse-integer (token)))) + (let* ((face-name (token)) + (height (integer)) + (width (integer)) + (weight (integer)) + (italic (integer)) + (win-font (win::create-font height width 0 0 weight italic + 0 0 0 0 0 0 0 face-name))) + (select-font win-font) + (multiple-value-bind (height ascent descent + internal-leading external-leading + average-character-width maximum-character-width + weight italic underlined struckout + first-character last-character default-character + break-character p&f character-set overhang + aspect-x aspect-y) + (win::get-text-metrics *dc*) + (declare (ignore p&f aspect-x aspect-y)) + (let ((cf + (make-cloe-font + :index win-font :height height :ascent ascent + :descent descent + :internal-leading internal-leading + :external-leading external-leading + :average-character-width average-character-width + :maximum-character-width maximum-character-width + :weight weight :italic italic + :underlined underlined :struckout struckout + :first-character first-character + :last-character last-character + :default-character default-character + :break-character break-character + :overhang overhang))) + (unless (= average-character-width + maximum-character-width) + (initialize-font-width-table cf window)) + cf))))))))) + + +;;; Font names are "Family-height-width-weight-italic"; must be strings because case matters. +(define-display-device *cloe-device* cloe-device + :font-for-undefined-style "Helv-10-10-400-0") + +;;; More to come, obviously. +(define-text-style-mappings *cloe-device* *standard-character-set* + (:family :fix (:face :roman (:size 22 "Courier-22-30-400-0" + 16 "Courier-16-10-400-0" + 12 "Courier-12-8-400-0" + 12 "Courier-10-8-400-0" + 7 "Courier-8-6-400-0" + 6 "Courier-6-5-400-0") + :bold (:size 22 "Courier-22-30-700-0" + 16 "Courier-16-10-700-0" + 12 "Courier-12-8-700-0" + 10 "Courier-10-8-700-0" + 8 "Courier-8-6-700-0" + 6 "Courier-6-5-700-0") + :italic (:size 22 "Courier-22-30-400-1" + 16 "Courier-16-10-400-1" + 12 "Courier-12-8-400-1" + 10 "Courier-10-8-400-1" + 8 "Courier-8-6-400-1" + 6 "Courier-6-5-400-1") + (:bold :italic) (:size 22 "Courier-22-30-700-1" + 16 "Courier-16-10-700-1" + 12 "Courier-12-8-700-1" + 10 "Courier-10-8-700-1" + 8 "Courier-8-6-700-1" + 6 "Courier-6-5-700-1")))) + +(define-text-style-mappings *cloe-device* *standard-character-set* + (:family :sans-serif (:face :roman (:size 22 "Helv-22-30-400-0" + 16 "Helv-16-10-400-0" + 12 "Helv-12-8-400-0" + 10 "Helv-10-8-400-0" + 8 "Helv-8-6-400-0" + 6 "Helv-6-5-400-0") + :bold (:size 22 "Helv-22-30-700-0" + 16 "Helv-16-10-700-0" + 12 "Helv-12-8-700-0" + 10 "Helv-10-8-700-0" + 8 "Helv-8-6-700-0" + 6 "Helv-6-5-700-0") + :italic (:size 22 "Helv-22-30-400-1" + 16 "Helv-16-10-400-1" + 12 "Helv-12-8-400-1" + 10 "Helv-10-8-400-1" + 8 "Helv-8-6-400-1" + 6 "Helv-6-5-400-1") + (:bold :italic) (:size 22 "Helv-22-30-700-1" + 16 "Helv-16-10-700-1" + 12 "Helv-12-8-700-1" + 10 "Helv-10-8-700-1" + 8 "Helv-8-6-700-1" + 6 "Helv-6-5-700-1")))) + +(define-text-style-mappings *cloe-device* *standard-character-set* + (:family :serif (:face :roman (:size 22 "TMS RMN-22-30-400-0" + 16 "TMS RMN-16-10-400-0" + 12 "TMS RMN-12-8-400-0" + 10 "TMS RMN-10-8-400-0" + 8 "TMS RMN-8-6-400-0" + 6 "TMS RMN-6-5-400-0") + :bold (:size 22 "TMS RMN-22-10-700-0" + 16 "TMS RMN-16-10-700-0" + 12 "TMS RMN-12-8-700-0" + 10 "TMS RMN-10-8-700-0" + 8 "TMS RMN-8-6-700-0" + 6 "TMS RMN-6-5-700-0") + :italic (:size 22 "TMS RMN-22-30-400-1" + 16 "TMS RMN-16-10-400-1" + 12 "TMS RMN-12-8-400-1" + 10 "TMS RMN-10-8-400-1" + 8 "TMS RMN-8-6-400-1" + 6 "TMS RMN-6-5-400-1") + (:bold :italic) (:size 22 "TMS RMN-22-30-700-1" + 16 "TMS RMN-16-10-700-1" + 12 "TMS RMN-12-8-700-1" + 10 "TMS RMN-10-8-700-1" + 8 "TMS RMN-8-6-700-1" + 6 "TMS RMN-6-5-700-1")))) + +(defparameter *cloe-logical-size-alist* + '((:tiny 6) + (:very-small 8) + (:small 10) + (:normal 12) + (:large 16) + (:very-large 22))) + +(defmethod standardize-text-style ((display-device cloe-device) character-set style) + (standardize-text-style-1 + display-device style character-set *cloe-logical-size-alist*)) + + +;;; These should really be defined in CL-STREAM, but doing it causes CLOE to +;;; go south during the build, my guess is the regular streams get trashed. +;;; So anyway we now do it here. + +(clos:defmethod stream-read-byte ((stream t)) + (read-byte stream nil :eof)) + +(clos:defmethod stream-read-char ((stream t)) + (read-char stream nil :eof)) + +(clos:defmethod stream-unread-char ((stream t) character) + (unread-char character stream)) + +(clos:defmethod stream-read-char-no-hang ((stream t)) + (read-char-no-hang stream nil :eof)) + +(clos:defmethod stream-peek-char ((stream t)) + (peek-char nil stream nil :eof)) + +(clos:defmethod stream-listen ((stream t)) + (listen stream)) + +(clos:defmethod stream-read-line ((stream t)) + (read-line stream nil :eof)) + +(clos:defmethod stream-clear-input ((stream t)) + (clear-input stream)) + +(clos:defmethod stream-write-byte ((stream t) integer) + (write-byte integer stream)) + +(clos:defmethod stream-write-char ((stream t) character) + (write-char character stream)) + +(clos:defmethod stream-write-string ((stream t) string &optional (start 0) end) + (write-string string stream + :start start + :end end)) + +(clos:defmethod stream-terpri ((stream t)) (terpri stream)) + + +(clos:defmethod stream-fresh-line ((stream t)) + (fresh-line stream)) + +(clos:defmethod stream-force-output ((stream t)) + (force-output stream)) + +(clos:defmethod stream-finish-output ((stream t)) + (finish-output stream)) + +(clos:defmethod stream-clear-output ((stream t)) + (clear-output stream)) diff --git a/pre-silica/clx-implementation.lisp b/pre-silica/clx-implementation.lisp new file mode 100644 index 00000000..5d38d240 --- /dev/null +++ b/pre-silica/clx-implementation.lisp @@ -0,0 +1,1586 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: clx-implementation.lisp,v 1.15 91/04/17 15:57:02 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(defclass clx-display-device (display-device) ()) + +(defvar *clx-font-families* '((:fix "*-courier-*") + (:sans-serif "*-helvetica-*") + (:serif "*-charter-*" "*-new century schoolbook-*" "*-times-*"))) + +(defun disassemble-x-font-name (name) + (let ((cpos 0) + (tokens nil)) + (loop + (let ((dpos (position #\- name :start cpos))) + (when (null dpos) + (push (subseq name cpos) tokens) + (return)) + (push (if (= cpos dpos) + nil + (subseq name cpos dpos)) + tokens) + (setf cpos (1+ dpos)))) + (reverse tokens))) + +(defmethod initialize-instance :after ((display-device clx-display-device) &key display) + ;; Sort of cheating, but ... + (setf (text-style-mapping + display-device *standard-character-set* *undefined-text-style*) + '(:style :fix :roman 10)) + ;;--- Bad idea to override the undefined mapping as above without guaranteeing + ;;--- that (:FIX :ROMAN 12) maps to something! Hopefully this mapping will be + ;;--- replaced by the initialization code below, but if not at least we have a + ;;--- fallback. For example, on the Genera X Server XLIB:LIST-FONTS is broken + ;;--- so no text styles get defined. + (setf (text-style-mapping + display-device *standard-character-set* (parse-text-style '(:fix :roman 12))) + (xlib:open-font display "8x13")) + (flet ((font->text-style (font family) + (let* ((tokens (disassemble-x-font-name (xlib: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))) + (point-size (or (xlib:font-property font :point_size) + (parse-integer (ninth tokens)))) + (size (round point-size 10))) + (when size + (make-text-style family face size))))) + (dolist (family-stuff *clx-font-families*) + (let ((family (car family-stuff))) + (dolist (font-pattern (cdr family-stuff)) + (dolist (xfont (xlib:list-fonts display font-pattern)) + (let ((text-style (font->text-style xfont family))) + (when text-style + ;; prefer first font satisfying this text style, so + ;; don't override if we've already defined one. + (unless (text-style-mapping-exists-p + display-device *standard-character-set* text-style) + (setf (text-style-mapping + display-device *standard-character-set* text-style) + xfont)))))))))) + +(defparameter *clx-logical-size-alist* + '((:tiny 6) + (:very-small 8) + (:small 10) + (:normal 12) + (:large 14) + (:very-large 18) + (:huge 24))) + +(defmethod standardize-text-style ((display-device clx-display-device) character-set style) + (standardize-text-style-1 + display-device style character-set *clx-logical-size-alist*)) + + +(defclass clx-root-window + (window-stream) + ((display) + (screen :reader clx-stream-screen) + (window :reader clx-stream-window) + (modifier-state :initform (make-modifier-state) + :reader window-modifier-state) + ;; Used to create "color" stipples on monochrome screens + (stipple-gc)) + (:default-initargs :input-buffer nil)) + +(defun disassemble-display-spec (display &optional (default-display 0) (default-screen 0)) + (declare (values host display-number nscreen)) + (let ((host-n (position #\: display))) + (unless host-n + (return-from disassemble-display-spec + (values display default-display default-screen))) + (let* ((host (subseq display 0 host-n)) + (screen-n (position #\. display :start (1+ host-n))) + (display-number (if screen-n + (parse-integer display :start (1+ host-n) :end screen-n + :junk-allowed t) + (parse-integer display :start (1+ host-n) + :junk-allowed t))) + (nscreen (if screen-n + (parse-integer display :start (1+ screen-n) + :junk-allowed t) + default-screen))) + (values host display-number nscreen)))) + +(defmethod initialize-instance :before + ((stream clx-root-window) + &key (host #+Genera (scl:send neti:*local-host* :name) + #+Minima (machine-instance) + #+Allegro (or (system:getenv "DISPLAY") (short-site-name)) + #+Lucid (or (lcl:environment-variable "DISPLAY") + (machine-instance))) + ((:display display-number) 0) + ((:screen nscreen) 0)) + (multiple-value-bind (host display-number nscreen) + (disassemble-display-spec host display-number nscreen) + (with-slots (display screen window display-device-type + left top right bottom stipple-gc) stream + (setf display (xlib:open-display host :display display-number)) + (fill-keycode->modifier-state display) + (fill-clim-modifier-key-index->x-state display) + (setf screen (nth nscreen (xlib:display-roots display))) + (setf window (xlib:screen-root screen)) + (setf left 0) + (setf top 0) + (setf right (xlib:screen-width screen)) + (setf bottom (xlib:screen-height screen)) + (setf display-device-type + (make-instance 'clx-display-device + :display display :name (format nil "~A" display))) + (setf stipple-gc (xlib:create-gcontext + :drawable window + :foreground (xlib:screen-black-pixel screen) + :background (xlib:screen-white-pixel screen)))) + (setf (stream-pointers stream) + (list (setf (stream-primary-pointer stream) + (make-instance 'standard-pointer :root stream)))))) + +;;; --- What should this really be returning? +(defmethod host-window-margins ((stream clx-root-window)) + (values 0 0 0 0)) + +(defmethod window-stream-class-name ((stream clx-root-window)) + 'clx-window) + +(defmethod clx-stream-root ((stream clx-root-window)) + stream) + +(defmethod close ((stream clx-root-window) &key abort) + (with-slots (window) stream + (when window + (xlib:close-display (xlib:window-display (shiftf window nil)) :abort abort)))) + +;;; Convert an X keycode into a CLIM modifier state that can be IORed with +;;; another modifier state. +;;; We'll just use an array that's DISPLAY-MAX-KEYCODEs long and index each keycode +;;; to a modifier state. +(defun keycode->modifier-state (keycode display) + (let ((array (getf (xlib:display-plist display) 'keycode->modifier-state))) + (aref array keycode))) + +(defun fill-keycode->modifier-state (display) + (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) + (xlib:modifier-mapping display) + (declare (ignore lock)) + (declare (ignore mod4 mod5)) + (let ((array (getf (xlib:display-plist display) 'keycode->modifier-state)) + (n-keycodes (1+ (xlib:display-max-keycode display)))) + (cond ((or (null array) + (< (length array) + n-keycodes)) + (setq array (make-array n-keycodes :element-type '(unsigned-byte 8) + :initial-element 0)) + (setf (getf (xlib:display-plist display) 'keycode->modifier-state) + array)) + (t (fill array 0))) + (flet ((x-name->clim-name (name) + ;;; for now, 1 = meta, 2 = super and 3 = hyper. + (ecase name + ((:shift :control) name) + (:mod1 :meta) + (:mod2 :super) + (:mod3 :hyper)))) + (macrolet ((do-shift (x-name) + `(let* ((clim-name (x-name->clim-name + ,(intern (symbol-name x-name) *keyword-package*))) + (modifier-state (if clim-name + (make-modifier-state clim-name) + 0))) + (dolist (code ,x-name) + (setf (aref array code) modifier-state))))) + (do-shift shift) + (do-shift control) + (do-shift mod1) + (do-shift mod2) + (do-shift mod3)))))) + +(defun fill-clim-modifier-key-index->x-state (display) + (multiple-value-bind (shift lock control mod-1 mod-2 mod-3 mod-4 mod-5) + (xlib:modifier-mapping display) + (declare (ignore shift lock control)) + (let ((array (getf (xlib:display-plist display) 'clim-modifier-key-index->x-state)) + (length (length *modifier-keys*))) + (cond ((or (null array) + (< (length array) length)) + (setq array (make-array length :element-type '(unsigned-byte 8) + :initial-element 0)) + (setf (getf (xlib:display-plist display) 'clim-modifier-key-index->x-state) + array)) + (t (fill array 0))) + ;; Maybe we can speed this up by special casing :SHIFT and :CONTROL + ;; somewhere else. + (setf (aref array (modifier-key-index :shift)) (xlib:make-state-mask :shift)) + (setf (aref array (modifier-key-index :control)) (xlib:make-state-mask :control)) + + (flet ((test-keysym (keysym state-mask) + (cond ((or (= keysym xlib::left-meta-keysym) + (= keysym xlib::right-meta-keysym)) + (setf (aref array (modifier-key-index :meta)) state-mask)) + ((or (= keysym xlib::left-super-keysym) + (= keysym xlib::right-super-keysym)) + (setf (aref array (modifier-key-index :super)) state-mask)) + ((or (= keysym xlib::left-hyper-keysym) + (= keysym xlib::right-hyper-keysym)) + (setf (aref array (modifier-key-index :hyper)) state-mask))))) + (macrolet ((do-mod (mod) + `(let ((codes ,mod)) + (dolist (keycode codes) + (let ((keysym (xlib:keycode->keysym display keycode 0))) + (test-keysym + keysym (xlib:make-state-mask + ,(intern (symbol-name mod) *keyword-package*)))))))) + (do-mod mod-1) + (do-mod mod-2) + (do-mod mod-3) + (do-mod mod-4) + (do-mod mod-5)))))) + +;;; Don't want to have to always go through the plist. +;;; We can store this info in slots in the root window +;;; and pass the arrays in as args. +(defun clim-modifier-key-index->x-state (modifier-key-index display) + (let ((array (getf (xlib:display-plist display) + 'clim-modifier-key-index->x-state))) + (aref array modifier-key-index))) + +(defun state-mask->modifier-state (state-mask display) + (let ((mask 0)) + (macrolet ((do-shift (clim-shift) + `(let* ((bit (modifier-key-index ,clim-shift)) + (x-state (clim-modifier-key-index->x-state bit display))) + (unless (zerop (boole boole-and x-state state-mask)) + (setf mask (dpb 1 (byte 1 bit) mask)))))) + (do-shift :shift) + (do-shift :control) + (do-shift :meta) + (do-shift :super) + (do-shift :hyper)) + mask)) + +(defmethod stream-event-handler ((stream clx-root-window) + &key (timeout nil) + (input-wait-test nil) + (original-stream stream)) + ;; No hang-p argument, use :timeout 0. + (with-slots (display (root-window window) modifier-state) stream + (let ((pointer (stream-primary-pointer stream)) + ;; If we're inside an encapsulating stream, such as the input editor, and a window + ;; resizing event is received, don't get confused while handling the event + (*original-stream* nil) + event) + ;; Return after processing each event or after the timeout. + (loop + ;; The assumption is that the input-wait-test function can only change + ;; its value when an event is received and processed. The only + ;; commonly-desired exception is a timeout, which we provide directly. + (when (and input-wait-test (funcall input-wait-test original-stream)) + (return :input-wait-test)) + (when (not (or (xlib:event-listen display) + (not (xlib::buffer-input-wait display timeout)))) + (return :timeout)) + (setq event + (xlib:event-case (display :discard-p t :timeout timeout) + ((:motion-notify) (window) + ;; We use the pointer-motion-hint strategy to avoid event overload. + (let ((ws (getf (xlib:window-plist window) 'stream))) + (when ws + (multiple-value-bind (x y same-screen-p child mask root-x root-y root) + (xlib:query-pointer root-window) + (declare (ignore x y same-screen-p child mask root)) + (pointer-set-position* pointer root-x root-y) + (setf (pointer-window pointer) ws) + (setf (pointer-motion-pending ws pointer) T)))) + :mouse-motion) + ((:button-press :button-release) (window event-key code x y state) + (let ((ws (getf (xlib:window-plist window) 'stream)) + (old-state (pointer-button-state pointer)) + ;; X enumerates buttons, we need a mask... + ;;--- Why isn't this just (ASH 1 CODE)? + (new-state (dpb 1 (byte 1 (1- code)) 0))) + (setf (pointer-button-state pointer) + (ecase event-key + (:button-press (logior new-state old-state)) + (:button-release (logandc1 new-state old-state)))) + (setf (pointer-window pointer) ws) + ;; Resolve the selected-window issue. We currently just put the + ;; button-press "blip" in the clicked-on window's input buffer. + (when ws + ;; X and Y are presumed to be fixnums here + (case event-key + (:button-press + (stream-note-pointer-button-press + ws pointer new-state modifier-state x y)) + (:button-release + (when *generate-button-release-events* + (stream-note-pointer-button-release + ws pointer new-state modifier-state x y)))))) + :input-buffer) + ((:key-press :key-release) (window child code state event-key) + (let ((ws (getf (xlib:window-plist (or child window)) 'stream))) + (let ((ch (xlib:keycode->character display code state))) + (cond ((characterp ch) + (when (and ws (eql event-key :key-press)) + (queue-put (stream-input-buffer ws) ch)) + ;; Store the modifier state in a canonical place. + (setf modifier-state (state-mask->modifier-state state display))) + (t + ;; Save away the current set of shifts. + (let ((state-modifier-state + (state-mask->modifier-state state display)) + (shift-modifier-state + (keycode->modifier-state code display))) + (case event-key + (:key-press + (setf modifier-state + (boole boole-ior + state-modifier-state shift-modifier-state))) + (:key-release + (setf modifier-state + (boole boole-andc2 + state-modifier-state shift-modifier-state))))))))) + :input-buffer) + ((:mapping-notify) (request start count) + (xlib:mapping-notify display request start count) + (when (eql request :modifier) + (fill-keycode->modifier-state display) + (fill-clim-modifier-key-index->x-state display)) + nil) + ((:reparent-notify) (window parent x y) + ;; We're interested in the relationship between our window and our + ;; parent, so if that's what this event is about, take notice. If + ;; the event is about any other windows (e.g. intermediaries inserted + ;; by the window manger), then it's talking about something beyond + ;; our sphere of influence and we ignore it. + (let ((ws (getf (xlib:window-plist window) 'stream)) + (ps (getf (xlib:window-plist parent) 'stream))) + (when (and ws ps (eq (window-parent ws) ps)) + (with-slots (left top right bottom) ws + (unless (and (= x left) (= y top)) + (window-note-size-or-position-change + ws x y (+ x (- right left)) (+ y (- bottom top))))))) + nil) + ((:configure-notify) (window width height x y) + (let ((ws (getf (xlib:window-plist window) 'stream))) + ;; we have to discard the current event now because we'll likely + ;; THROW out and we don't want to process it again. + ;;--- This may be a problem in R4.4 CLX. -- jdi + (xlib:discard-current-event display) + (when ws + (window-note-size-or-position-change + ws x y (+ x width) (+ y height)))) + nil) + ((:graphics-exposure :exposure) (event-window width height x y count) + ;; --- We're actually losing here because we have to forcibly + ;; read out and process the graphicsExpose (or noExpose) event at + ;; COPY-AREA time to ensure the consistency of the display. + (let ((ws (getf (xlib:window-plist event-window) 'stream))) + (when ws + (with-slots (update-region) ws + (multiple-value-bind (dsx dsy) + ;; transform these coords into history coords, adding viewport, substracting margin + (viewport-to-drawing-surface-coordinates ws x y) + (push (make-bounding-rectangle dsx dsy (+ dsx width) (+ dsy height)) + update-region))) + (when (zerop count) + ;; if no expose events are to come, repaint the stream. + (window-process-update-region ws)))) + nil))) + (if event + (return event) + (return :timeout)))))) + + + +(defclass clx-window + (window-stream) + ((screen :reader clx-stream-screen) + (window :reader clx-stream-window) + (root :reader clx-stream-root) + (color-p :initform nil) + ;; These two are used on monochrome screens + (white-pixel) + (black-pixel) + (copy-gc) + (foreground-gc) + (foreground-pixel) + (background-gc) + (background-pixel) + (flipping-gc) + (ink-table :initform (make-hash-table :test #'equal)) + (clip-mask :initform :none) + (points-to-pixels) + (vertical-scroll-bar :initform nil :reader window-vertical-scroll-bar) + (horizontal-scroll-bar :initform nil :reader window-horizontal-scroll-bar))) + +(defparameter *clx-use-color* t) ;for debugging monochrome... +(defmethod color-stream-p ((stream clx-window)) + (and *clx-use-color* + (> (xlib:screen-root-depth (clx-stream-screen stream)) 2))) + +(defparameter *clx-scrollbar-border-width* 0) +(defparameter *clx-scrollbar-width* 14) + +;;--- Scrollbars have an inner margin +;;--- Perhaps we should use window-margin! +(defvar *clx-scrollbar-inner-margin* 2) + +(defclass clx-scrollbar (clx-window) + ((scroll-bar-values-1 :initform nil + :accessor scroll-bar-values-1) + (scroll-bar-values-2 :initform nil + :accessor scroll-bar-values-2))) + +(defclass clx-h-scrollbar (clx-scrollbar) ()) +(defclass clx-v-scrollbar (clx-scrollbar) ()) + +(defmethod initialize-instance :before ((stream clx-window) &key parent) + (setf (slot-value stream 'display-device-type) + (slot-value parent 'display-device-type))) + +(defmethod initialize-instance :after + ((stream clx-window) &key left top right bottom + (scroll-bars :both) save-under label (borders t)) + (with-slots (window root screen copy-gc points-to-pixels + color-p black-pixel white-pixel) stream + (let* ((parent (window-parent stream)) + (top-level (null (window-parent parent))) + (border-width (if borders 2 0))) + (setf root (clx-stream-root parent)) + (setf screen (clx-stream-screen parent)) + (setf color-p (color-stream-p stream)) + (setf white-pixel (xlib:screen-white-pixel screen)) + (setf black-pixel (xlib:screen-black-pixel screen)) + (setf points-to-pixels (* (sqrt (* (/ (xlib:screen-width screen) + (xlib:screen-width-in-millimeters screen)) + (/ (xlib:screen-height screen) + (xlib:screen-height-in-millimeters screen)))) + (/ 25.4s0 72))) + (let ((rounded (round points-to-pixels))) + (when (< (abs (- points-to-pixels rounded)) .1s0) + (setf points-to-pixels rounded))) + (cond (top-level + (setf window (xlib:create-window + :parent (clx-stream-window parent) + :x left :y top :width (- right left) :height (- bottom top) + ;; putting in bit-gravity reduces the number + ;; of repaint events we have to process when we resize the window. + :bit-gravity :north-west + :save-under (if save-under :on nil) + :event-mask '(:key-press :button-press + :key-release :button-release + :pointer-motion :pointer-motion-hint + :structure-notify + :exposure) + :border-width border-width)) + (setf (window-label stream) label) + (xlib:set-wm-properties window :input :on :initial-state :normal)) + (t + (setf window (xlib:create-window + :parent (clx-stream-window parent) + :x left :y top :width (- right left) :height (- bottom top) + :event-mask '(:button-press :button-release + :pointer-motion :pointer-motion-hint + :exposure) + ;; putting in bit-gravity reduces the number of repaint + ;; events we have to process when we resize the window. + :bit-gravity :north-west + :border-width border-width)) + (setf (stream-input-buffer stream) (stream-input-buffer parent))))) + (setf copy-gc (xlib:create-gcontext :drawable window :exposures nil)) + (clx-recompute-gcs stream) + (setf (getf (xlib:window-plist window) 'stream) stream)) + (when scroll-bars + (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream + (let ((hp (member scroll-bars '(:both :horizontal))) + (vp (member scroll-bars '(:both :vertical)))) + (when hp + (setf horizontal-scroll-bar + (open-window-stream :parent stream + :window-class 'clx-h-scrollbar + :borders nil + :left (if vp *clx-scrollbar-width* 0) + :right (- right left) + :top (- bottom top *clx-scrollbar-width*) + :bottom (- bottom top) + :scroll-bars nil)) + (setf (stream-recording-p horizontal-scroll-bar) nil) + (window-expose horizontal-scroll-bar)) + (when vp + (setf vertical-scroll-bar + (open-window-stream :parent stream + :borders nil + :window-class 'clx-v-scrollbar + :left 0 :right *clx-scrollbar-width* + :top 0 :bottom (- bottom top + (if hp *clx-scrollbar-width* 0)) + :scroll-bars nil)) + (setf (stream-recording-p vertical-scroll-bar) nil) + (window-expose vertical-scroll-bar)))))) + + +;;; Scroll bars + +(defmethod stream-replay ((stream clx-scrollbar) &optional region) + (declare (ignore region)) + (draw-scrollbar stream t)) + +(defmethod stream-note-pointer-button-press ((bar clx-v-scrollbar) + pointer button modifier-state x y) + (declare (ignore pointer modifier-state x)) + (let* ((stream (window-parent bar)) + (history (stream-output-history stream))) + (when history + (with-bounding-rectangle* (hleft htop hright hbottom) history + (declare (ignore hleft hright)) + (with-bounding-rectangle* (v-left v-top v-right v-bottom) (window-viewport stream) + (declare (ignore v-right)) + (window-set-viewport-position* stream + v-left + (compute-scroll-to-value + y (bounding-rectangle-width bar) (bounding-rectangle-height bar) + htop hbottom v-top v-bottom button)) + (draw-scrollbar bar)))))) + +(defmethod stream-note-pointer-button-press ((bar clx-h-scrollbar) + pointer button modifier-state x y) + (declare (ignore pointer modifier-state y)) + (let* ((stream (window-parent bar)) + (history (stream-output-history stream))) + (when history + (with-bounding-rectangle* (hleft htop hright hbottom) history + (declare (ignore htop hbottom)) + (with-bounding-rectangle* (v-left v-top v-right v-bottom) (window-viewport stream) + (declare (ignore v-bottom)) + (window-set-viewport-position* stream + (compute-scroll-to-value + x (bounding-rectangle-height bar) (bounding-rectangle-width bar) + hleft hright v-left v-right button) + v-top) + (draw-scrollbar bar)))))) + +(defun compute-scroll-to-value (y bar-width bar-height + history-top history-bottom viewport-top viewport-bottom + button) + (cond + ;; top + ((if (= button 1) (< y bar-width) (> y (- bar-height bar-width))) + (max history-top + (- viewport-top (truncate (* 0.9 (- viewport-bottom viewport-top)))))) + ;; bottom + ((if (= button 1) (> y (- bar-height bar-width)) (< y bar-width)) + (min (- history-bottom (- viewport-bottom viewport-top)) + (+ viewport-top (truncate (* 0.9 (- viewport-bottom viewport-top)))))) + ;; elsewhere + (t + (let* ((ratio (float (/ (max 0 (- y bar-width)) bar-height)))) + (min (- history-bottom (- viewport-bottom viewport-top)) + (truncate (+ history-top (* ratio (- history-bottom history-top))))))))) + +(defmacro with-scroll-bar-update (&body body) + `(unless (and (not force-p) + (eq slug-start (scroll-bar-values-1 stream)) + (eq slug-length (scroll-bar-values-2 stream))) + (let ((old-slug-start (scroll-bar-values-1 stream)) + (old-slug-length (scroll-bar-values-2 stream))) + (setf (scroll-bar-values-1 stream) slug-start + (scroll-bar-values-2 stream) slug-length) + ,@body))) + +(defmethod draw-scrollbar ((stream clx-v-scrollbar) &optional force-p) + (with-bounding-rectangle* (left top right bottom) stream + (let ((width (- right left)) + (height (- bottom top)) + (win (window-parent stream))) + (with-bounding-rectangle* (extent-left extent-top extent-right extent-bottom) + (stream-output-history win) + (declare (ignore extent-left extent-right)) + (with-bounding-rectangle* (viewport-left viewport-top viewport-right viewport-bottom) + (window-viewport win) + (declare (ignore viewport-left viewport-right)) + (multiple-value-bind (y1 y2 y3 y4 x1 x2 slug-start slug-length) + (compute-scrollbar-values + height width *clx-scrollbar-inner-margin* + extent-top extent-bottom viewport-top viewport-bottom) + (with-scroll-bar-update + (if (or force-p (null old-slug-start)) + (progn + (draw-rectangle* stream + 0 0 + (bounding-rectangle-width stream) (bounding-rectangle-height stream) + :ink +background-ink+) + (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +black+) + (draw-rectangle* stream x1 y3 x2 y4 :filled nil :ink +black+) + (draw-rectangle* stream x1 y2 x2 y3 :filled nil :ink +black+)) + ;; Clear the slug + (draw-rectangle* stream + (1+ x1) (min slug-start old-slug-start) + (1- x2) (max (+ slug-start slug-length) (+ old-slug-start old-slug-length)) + :ink +background-ink+)) + ;; Redraw the slug + (draw-rectangle* stream + (1+ x1) slug-start (1- x2) (+ slug-start slug-length) + :ink +light-gray+)))))))) + +(defmethod draw-scrollbar ((stream clx-h-scrollbar) &optional force-p) + (with-bounding-rectangle* (left top right bottom) stream + (let ((width (- right left)) + (height (- bottom top)) + (win (window-parent stream))) + (with-bounding-rectangle* (extent-left extent-top extent-right extent-bottom) + (stream-output-history win) + (declare (ignore extent-top extent-bottom)) + (with-bounding-rectangle* (viewport-left viewport-top viewport-right viewport-bottom) + (window-viewport win) + (declare (ignore viewport-top viewport-bottom)) + (multiple-value-bind (x1 x2 x3 x4 y1 y2 slug-start slug-length) + (compute-scrollbar-values + width height *clx-scrollbar-inner-margin* + extent-left extent-right viewport-left viewport-right) + (with-scroll-bar-update + (if (or force-p (null old-slug-start)) + (progn + (draw-rectangle* stream + 0 0 + (bounding-rectangle-width stream) (bounding-rectangle-height stream) + :ink +background-ink+) + (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +black+) + (draw-rectangle* stream x3 y1 x4 y2 :filled nil :ink +black+) + (draw-rectangle* stream x2 y1 x3 y2 :filled nil :ink +black+)) + ;; Clear the slug + (draw-rectangle* stream + (min slug-start old-slug-start) (1+ y1) + (max (+ slug-start slug-length) (+ old-slug-start old-slug-length)) (1- y2) + :ink +background-ink+)) + ;; Redraw the slug + (draw-rectangle* stream + slug-start (1+ y1) (+ slug-start slug-length) (1- y2) + :ink +light-gray+)))))))) + +(defun compute-scrollbar-values (long short margin + extent-min extent-max viewport-min viewport-max) + (let* ((square (- short (* 2 margin))) + (x1 margin) + (x2 (+ x1 square)) + (x4 (- long margin)) + (x3 (- x4 square)) + (y1 margin) + (y2 (- short margin)) + (esize (- (max viewport-max extent-max) (min viewport-min extent-min))) + (vsize (- viewport-max viewport-min)) + (ratio (float (/ (max 1 vsize) (max vsize 1 esize)))) + (available-size (- x3 x2 2)) + (slug-length (* available-size ratio)) + (left (- available-size slug-length)) + (slug-start (+ x2 (* left (/ (- viewport-min extent-min) + (max 1 (- esize vsize)))) 1))) + (values x1 x2 x3 x4 y1 y2 (floor slug-start) (floor slug-length)))) + +;; Update the scroll-bars when their parent window changes +(defun update-scrollbars (stream width height) + (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream + (when vertical-scroll-bar + (bounding-rectangle-set-size + vertical-scroll-bar + (bounding-rectangle-width vertical-scroll-bar) + (if horizontal-scroll-bar (- height *clx-scrollbar-width*) height)) + (draw-scrollbar vertical-scroll-bar t)) + (when horizontal-scroll-bar + (bounding-rectangle-set-edges + horizontal-scroll-bar + (if vertical-scroll-bar *clx-scrollbar-width* 0) + (- height *clx-scrollbar-width*) + width + height) + (draw-scrollbar horizontal-scroll-bar)))) + +(defmethod host-window-margins ((stream clx-window)) + (values 0 0 0 0)) + +(defmethod window-margins ((stream clx-window)) + (let ((h (window-horizontal-scroll-bar stream)) + (v (window-vertical-scroll-bar stream))) + (values (if v + (+ (* 2 *clx-scrollbar-border-width*) (bounding-rectangle-width v)) + 0) + 0 + 0 + (if h + (+ (* 2 *clx-scrollbar-border-width*) (bounding-rectangle-height h)) + 0)))) + +(defmethod window-note-size-or-position-change :after + ((stream clx-window) new-left new-top new-right new-bottom) + (update-scrollbars stream (- new-right new-left) (- new-bottom new-top))) + + +;;; This is called by the menu facility. Under X, we simply set the transient-for +;;; slot to tell the window manager not to interfere with this window. +(defmethod initialize-menu :after ((stream clx-window) associated-window) + ;;--- May actually want to go :OVERRIDE-REDIRECT here. -- jdi + (when associated-window + (setf (xlib:transient-for (slot-value stream 'window)) + (slot-value associated-window 'window)))) + +(defmethod (setf medium-foreground) :after (ink (stream clx-window)) + (declare (ignore ink)) + (clx-recompute-gcs stream)) + +(defmethod (setf medium-background) :after (ink (stream clx-window)) + (declare (ignore ink)) + (clx-recompute-gcs stream)) + +(defmethod window-modifier-state ((window clx-window)) + (window-modifier-state (clx-stream-root window))) + +(defmethod clx-recompute-gcs ((stream clx-window)) + (with-slots (foreground-gc foreground-pixel background-gc background-pixel + window flipping-gc) stream + (unless (slot-boundp stream 'foreground-gc) + (setf foreground-gc (xlib:create-gcontext :drawable window))) + (unless (slot-boundp stream 'background-gc) + (setf background-gc (xlib:create-gcontext :drawable window))) + (unless (slot-boundp stream 'flipping-gc) + (setf flipping-gc (xlib:create-gcontext :drawable window :function boole-xor))) + (flet ((do-ground (ink gc) + (setf (xlib:gcontext-fill-style gc) :solid) + (setf (xlib:gcontext-foreground gc) (clx-decode-color stream ink)))) + (setf foreground-pixel (do-ground (medium-foreground stream) foreground-gc)) + (setf background-pixel (do-ground (medium-background stream) background-gc))) + (cond ((and (integerp foreground-pixel) (integerp background-pixel)) + (setf (xlib:gcontext-background foreground-gc) background-pixel) + (setf (xlib:gcontext-fill-style flipping-gc) :solid) + (setf (xlib:gcontext-foreground flipping-gc) + (logxor foreground-pixel background-pixel))) + (t (nyi))) + (setf (xlib:window-background window) background-pixel))) + +(defmethod window-beep ((stream clx-window)) + (with-slots (window) stream + (let ((display (xlib:window-display window))) + (xlib:bell display) + (xlib:display-force-output display)))) + +(defmethod notify-user-1 ((stream clx-window) frame format-string &rest format-args) + (declare (ignore frame) (dynamic-extent format-args)) + (with-menu (window stream) + (with-end-of-line-action (window :allow) + (apply #'format window format-string format-args) + (fresh-line window) + (terpri window) + (with-text-size (window :smaller) + (write-string "Hit any key to remove this window" window)) + (force-output window) + (size-menu-appropriately window) + (position-window-near-carefully window 10 10) ;whatever... + (window-expose window) + (read-gesture :stream window)))) + +(defmethod implementation-pixels-per-point ((stream clx-window)) + (with-slots (screen) stream + (/ (xlib:screen-width screen) (* (/ 72 25.4) (xlib:screen-width-in-millimeters screen))))) + +(defmethod (setf window-label) :after (label (stream clx-window)) + (with-slots (window) stream + (multiple-value-bind (name icon-name) + (etypecase label + (null (values "CLIM Window" "CLIM")) + (string (values label label)) + (cons (values (first label) (first label)))) + (setf (xlib:wm-name window) name) + (setf (xlib:wm-icon-name window) icon-name)) + label)) + +;;; Debugging aid +(defparameter *clx-force-output* nil) + +(defun clx-force-output-if-necessary (stream &optional force-p) + (when (or force-p *clx-force-output*) + (xlib:display-force-output (xlib:window-display (slot-value stream 'window))))) + +(defmethod window-flush-update-region ((stream clx-window)) + (with-slots (update-region) stream + (setf update-region nil))) + +(defmethod window-process-update-region ((stream clx-window)) + (with-slots (update-region) stream + (when update-region + (dolist (rectangle update-region) + (with-bounding-rectangle* (left top right bottom) rectangle + (adjust-for-viewport-and-margins stream left top right bottom) + (window-clear-area stream left top right bottom)))))) + +(defmethod window-shift-visible-region :after ((stream clx-window) + old-left old-top old-right old-bottom + new-left new-top new-right new-bottom) + (let ((rectangles (ltrb-difference new-left new-top new-right new-bottom + old-left old-top old-right old-bottom))) + ;; Use the rectangle-list as the internal representation for a CLX-implementation region + (setf (slot-value stream 'update-region) rectangles))) + +(defmethod window-clear-area ((stream clx-window) left top right bottom) + (with-slots (window background-gc background-pixel) stream + (if (integerp background-pixel) + (xlib:clear-area window :x left :y top :width (- right left) :height (- bottom top)) + (xlib:draw-rectangle window background-gc left top (- right left) (- bottom top) t))) + (clx-force-output-if-necessary stream)) + +(defmethod copy-area ((stream clx-window) + from-left from-top from-right from-bottom + to-left to-top) + ;; coords in "host" coordinate system + (fix-points from-left from-top from-right from-bottom to-left to-top) + (with-slots (window copy-gc) stream + (let ((width (- from-right from-left)) + (height (- from-bottom from-top))) + (xlib:copy-area window copy-gc from-left from-top width height window to-left to-top))) + (clx-force-output-if-necessary stream)) + +;;--- This should clip to real regions, not just to bounding-rectangles +(defmethod invoke-with-clipping-region + ((stream clx-window) continuation (region standard-bounding-rectangle)) + (with-slots (window clip-mask) stream + (multiple-value-bind (x y) (window-viewport-position* stream) + (declare (type coordinate x y)) + (multiple-value-bind (ml mt) (window-margins stream) + (declare (type coordinate ml mt)) + (with-bounding-rectangle* (left top right bottom) region + (translate-fixnum-positions (- ml x) (- mt y) + left top right bottom) + ;;--- DEVICIZE-POINTS or something... + (fix-points left top right bottom) + ;;--- How not to cons? (this list and the rectangles) + (let ((old-clip-mask clip-mask)) + (unwind-protect + (progn + (setf clip-mask (list left top (- right left) (- bottom top))) + (funcall continuation stream)) + (setf clip-mask old-clip-mask)))))))) + + + +(defmethod stream-force-output ((stream clx-window)) + (xlib:display-force-output (xlib:window-display (slot-value stream 'window)))) + +(defmethod stream-finish-output ((stream clx-window)) + (xlib:display-finish-output (xlib:window-display (slot-value stream 'window)))) + +(defmethod stream-clear-output ((stream clx-window)) + ;;;--- Not yet implemented. + ) + +;;; Required +(defmethod stream-set-input-focus ((stream clx-window)) + ;;--- should there be a "default" method on input-protocol-mixin that + ;;--- does this?? + ) + +(defmethod stream-restore-input-focus ((stream clx-window) old-focus) + (declare (ignore old-focus)) + ;;--- should there be a "default" method on input-protocol-mixin that + ;;--- does this?? + ) + +(defmethod window-erase-viewport ((stream clx-window)) + (when (window-drawing-possible stream) + (with-slots (window) stream + (xlib:clear-area window)) + (clx-force-output-if-necessary stream))) + +(defmethod window-visibility ((stream clx-window)) + (with-slots (window) stream + (not (eq (xlib:window-map-state window) :unmapped)))) + +(defmethod (setf window-visibility) (visibility (stream clx-window)) + (with-slots (window screen) stream + ;; Have to wait for map to happen or subsequent output is lost + ;;--- How do we deal with state :UNVIEWABLE? It means that window is + ;;--- mapped but some superior isn't. Do we propagate visibility up? + ;;--- I think not. + (if visibility ; visibility is a boolean + ;; This isn't quite right, because activating it means it's now buried?? + ;; Fine: that's what WINDOW-EXPOSE is for. -- jdi + (xlib:map-window window) + ;;--- WITHDRAW-WINDOW isn't in R3 CLX. + (if (fboundp 'xlib::withdraw-window) + (xlib::withdraw-window window screen) + (xlib:unmap-window window)))) + (clx-force-output-if-necessary stream)) + +(defmethod wait-for-window-exposed ((window clx-window)) + ;;--- This is expensive if the window manager doesn't map the window "soon" + (loop + (when (window-visibility window) + (return)) + (process-yield))) + +(defmethod window-drawing-possible ((stream clx-window)) + ;;--- This isn't really right for a window that has backing store. + (with-slots (window) stream + (not (eq (xlib:window-map-state window) :unmapped)))) + +(defmethod window-stack-on-top ((stream clx-window)) + (with-slots (window) stream + (setf (xlib:window-priority window) :above)) + (clx-force-output-if-necessary stream)) + +(defmethod window-stack-on-bottom ((stream clx-window)) + (with-slots (window) stream + (setf (xlib:window-priority window) :below)) + (clx-force-output-if-necessary stream)) + +(defmethod close ((stream clx-window) &key abort) + (declare (ignore abort)) + (with-slots (window) stream + (when window + (remf (xlib:window-plist window) 'stream) + (xlib:destroy-window (shiftf window nil)))) + (clx-force-output-if-necessary stream)) + +(defmethod bounding-rectangle-set-edges :after ((stream clx-window) left top right bottom) + (let ((width (- right left)) + (height (- bottom top))) + (with-slots (window) stream + (xlib:with-state (window) + (setf (xlib:drawable-x window) left + (xlib:drawable-y window) top + (xlib:drawable-width window) width + (xlib:drawable-height window) height))) + (update-scrollbars stream width height)) + (clx-force-output-if-necessary stream t)) + +(defmethod bounding-rectangle-set-position* :after ((stream clx-window) new-left new-top) + (with-slots (window) stream + (xlib:with-state (window) + (setf (xlib:drawable-x window) new-left) + (setf (xlib:drawable-y window) new-top))) + (clx-force-output-if-necessary stream t)) + +(defmethod bounding-rectangle-set-size :after ((stream clx-window) width height) + (with-slots (window) stream + (xlib:with-state (window) + (setf (xlib:drawable-width window) width + (xlib:drawable-height window) height))) + (update-scrollbars stream width height) + (clx-force-output-if-necessary stream t)) + +(defmethod redisplay-decorations ((stream clx-window)) + (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream + (when vertical-scroll-bar + (draw-scrollbar vertical-scroll-bar)) + (when horizontal-scroll-bar + (draw-scrollbar horizontal-scroll-bar)))) + + + +;;; Input side + +(defmethod set-pointer-window-and-location ((stream clx-window) pointer) + ;;--- What should this do? + ) + +;;; The root stream-event-handler will do the appropriate keyword validation +(defmethod stream-event-handler ((stream clx-window) &rest args &key &allow-other-keys) + (declare (dynamic-extent args)) + (with-slots (root) stream + (apply #'stream-event-handler root :original-stream stream args))) + +(defmethod set-stream-pointer-in-screen-coordinates + ((stream clx-window) pointer x y) + (declare (ignore pointer)) ;Sigh. + (xlib:warp-pointer (xlib:drawable-root (clx-stream-window stream)) x y)) + +(defmethod stream-pointer-input-rectangle* + ((stream clx-window) pointer &key left top right bottom) + (declare (ignore left top right bottom)) + (portable-pointer-input-rectangle* stream pointer)) + + +;;; Colors and their monochrome imposters + +(defun make-stipple-image (height width patterns) + (xlib:create-image :width width :height height + :data (make-stipple-array height width patterns) + :bits-per-pixel 1)) + +(defvar *clx-luminance-stipples* + (mapcar #'(lambda (entry) + (cons (first entry) (apply #'make-stipple-image (second entry)))) + '((0.1 (8 16 (#b0111111111111111 + #b1111110111111111 + #b1111111111110111 + #b1101111111111111 + #b1111111101111111 + #b1111111111111101 + #b1111011111111111 + #b1111111111011111))) + (0.2 (8 8 (#b01111111 + #b11101111 + #b11111101 + #b10111111 + #b11110111 + #b11111110 + #b11011111 + #b11111011))) + (0.3 (4 4 (#b0111 + #b1101 + #b1011 + #b1110))) + (0.4 (3 3 (#b011 + #b101 + #b110))) + (0.6 (2 2 (#b01 + #b10))) + (0.7 (3 3 (#b100 + #b010 + #b001))) + (0.8 (4 4 (#b1000 + #b0010 + #b0100 + #b0001))) + (0.9 (8 8 (#b10000000 + #b00010000 + #b00000010 + #b01000000 + #b00001000 + #b00000001 + #b00100000 + #b00000100))) + (0.95 (8 16 (#b1000000000000000 + #b0000001000000000 + #b0000000000001000 + #b0010000000000000 + #b0000000010000000 + #b0000000000000010 + #b0000100000000000 + #b0000000000100000)))))) + +;; The xlib:image objects are created at load time to save run time & space. +;; Here a '0' means white, '1' black. +(defun clx-decode-luminance (luminance stipple-p) + (if (not stipple-p) + (if (< luminance 0.5) 1 0) + (if (< luminance 0.05) + 1 + (dolist (entry *clx-luminance-stipples* 0) + (let ((l (car entry)) + (stipple (cdr entry))) + (when (< luminance l) + (return-from clx-decode-luminance stipple))))))) + +;; This should only be called on a color screen. +(defmethod clx-decode-color ((stream clx-window) (ink color)) + (with-slots (screen color-p black-pixel) stream + (multiple-value-bind (red green blue) (color-rgb ink) + ;;--- Should probably use COLOR-P here. Otherwise if *CLX-USE-COLOR* is NIL, + ;;--- colors can still be used for foreground, background, patterns. + (handler-case + (xlib:alloc-color (xlib:screen-default-colormap screen) + ;; Either someone has to ensure the the color values in a color + ;; object are floats, or we have to here. + (xlib:make-color :red (float red) + :green (float green) + :blue (float blue))) + ;;--- Have to handle resource exhaustion better here. -- jdi + (xlib:alloc-error (condition) + (declare (ignore condition)) + (warn "No more colors available for ~S, using black instead." ink) + black-pixel))))) + +(defmethod clx-decode-color ((stream clx-window) (ink (eql +foreground-ink+))) + (slot-value stream 'foreground-pixel)) + +(defmethod clx-decode-color ((stream clx-window) (ink (eql +background-ink+))) + (slot-value stream 'background-pixel)) + +;;--- We can surely do better than this +(defmethod clx-decode-color ((stream clx-window) (ink standard-opacity)) + (if (> (slot-value ink 'clim-utils::value) 0.5) + (slot-value stream 'foreground-pixel) + (slot-value stream 'background-pixel))) + +(defgeneric clx-decode-ink (ink stream)) + +(defmethod clx-decode-ink ((ink (eql +foreground-ink+)) stream) + (slot-value stream 'foreground-gc)) + +(defmethod clx-decode-ink ((ink (eql +background-ink+)) stream) + (slot-value stream 'background-gc)) + +(defmethod clx-decode-ink ((ink (eql +flipping-ink+)) stream) + (slot-value stream 'flipping-gc)) + +(defmethod clx-decode-ink ((ink flipping-ink) stream) + (multiple-value-bind (design1 design2) + (decode-flipping-ink ink) + (cond ((or (and (eq design1 +foreground-ink+) (eq design2 +background-ink+)) + (and (eq design1 +background-ink+) (eq design2 +foreground-ink+))) + (slot-value stream 'flipping-gc)) + (t (nyi))))) + +(defmethod clx-decode-ink ((ink color) stream) + (with-slots (window ink-table foreground-gc color-p black-pixel white-pixel root) stream + (or (gethash ink ink-table) + (let ((gc (xlib:create-gcontext :drawable window))) + (xlib:copy-gcontext foreground-gc gc) + (cond (color-p + (setf (xlib:gcontext-fill-style gc) :solid + (xlib:gcontext-foreground gc) (clx-decode-color stream ink))) + (t + (multiple-value-bind (r g b) (color-rgb ink) + (let* ((luminance (color-luminosity r g b)) + (color (clx-decode-luminance luminance t))) + (cond ((eql color 1) + (setf (xlib:gcontext-fill-style gc) :solid + (xlib:gcontext-foreground gc) black-pixel)) + ((eql color 0) + (setf (xlib:gcontext-fill-style gc) :solid + (xlib:gcontext-foreground gc) white-pixel)) + (t ; color is an image + (setf (xlib:gcontext-fill-style gc) :tiled) + (let ((pixmap (xlib:create-pixmap + :drawable window + :width (xlib:image-width color) + :height (xlib:image-height color) + ;;--- is this right? + :depth (xlib:drawable-depth window)))) + (xlib:put-image pixmap + (slot-value root 'stipple-gc) + color :x 0 :y 0 :bitmap-p t) + (setf (xlib:gcontext-tile gc) pixmap)))))))) + (setf (gethash ink ink-table) gc))))) + +(defmethod clx-decode-ink ((ink contrasting-ink) stream) + (clx-decode-ink (make-color-for-contrasting-ink ink) stream)) + +(defmethod clx-decode-ink ((ink rectangular-tile) stream) + (with-slots (ink-table) stream + (or (gethash ink ink-table) + (multiple-value-bind (pattern width height) + (decode-rectangular-tile ink) + (clx-decode-pattern pattern stream width height t))))) + +(defmethod clx-decode-ink ((ink pattern) stream) + (clx-decode-pattern ink stream)) + +(defmethod clx-decode-ink ((ink stencil) stream) + (declare (ignore stream)) + (error "Stencils and opacities are not supported in this CLIM implementation")) + +(defmethod clx-decode-ink ((ink composite-in) stream) + (declare (ignore stream)) + (error "Compositing is not supported in this CLIM implementation")) + +(defmethod clx-decode-ink ((ink composite-out) stream) + (declare (ignore stream)) + (error "Compositing is not supported in this CLIM implementation")) + +(defmethod clx-decode-pattern ((ink design) stream &optional width height tiled-p) + (declare (ignore stream width height tiled-p)) + (error "Arbitrary patterned designs are not supported in this CLIM implementation")) + +(defmethod clx-decode-pattern ((ink color) stream &optional width height tiled-p) + (declare (ignore stream width height tiled-p)) + (error "A pattern must be a bounded design, ~S isn't" ink)) + +(defmethod clx-decode-pattern ((ink pattern) stream &optional width height tiled-p) + (with-slots (foreground-gc foreground-pixel background-gc background-pixel + window ink-table screen) stream + (or (gethash ink ink-table) + (multiple-value-bind (array designs) + (decode-pattern ink) + (let ((pattern-height (array-dimension array 0)) + (pattern-width (array-dimension array 1))) + (declare (type xlib::array-index pattern-width pattern-height)) + (unless width + (setq width pattern-width)) + (unless height + (setq height pattern-height)) + #+++ignore + (do ((i 0 (1+ i)) + (design)) + ((eq i (length designs))) + (setq design (elt designs i)) + (when (and (not (colorp design)) + (not (eq design +foreground-ink+)) + (not (eq design +background-ink+))) + (error "Pattern designs other than colors are not supported yet."))) + (let* ((depth (xlib:screen-root-depth screen)) + (image-data (make-array (list height width) + :element-type `(unsigned-byte ,depth)))) + (do ((y 0 (1+ y))) + ((eq y height)) + (declare (type xlib::array-index y)) + (do ((x 0 (1+ x))) + ((eq x width)) + (declare (type xlib::array-index x)) + (setf (aref image-data y x) + (if (or (>= y pattern-height) (>= x pattern-width)) + background-pixel + (clx-decode-color stream (elt designs (aref array y x))))))) + (let ((gc (xlib:create-gcontext :drawable window))) + (xlib:copy-gcontext foreground-gc gc) + (setf (xlib:gcontext-fill-style gc) :tiled) + (setf (xlib:gcontext-tile gc) + (let ((image + (xlib:create-image :depth depth + :data image-data + :width width :height height)) + (pixmap + (xlib:create-pixmap :width width :height height + :drawable window + :depth depth))) + (xlib:put-image pixmap gc image :x 0 :y 0) + pixmap)) + (when (not tiled-p) + ;;--- This doesn't work because the clip mask is set below. + ;;--- Anyway, the clip-mask applies to the destination, so + ;;--- the x and y must be set correctly. -- jdi + (setf (xlib:gcontext-clip-mask gc) + (list 0 0 pattern-width pattern-height))) + (setf (gethash ink ink-table) gc)))))))) + +;;--- It would be nice if we did not have to cons up a new list each +;;--- time. Perhaps we could test if it had changed. Perhaps the global +;;--- value of the clipping rectangle could be determined in advance. +(defun compute-gcontext-clip-mask (stream clip-mask) + (multiple-value-bind + (left top right bottom) + (window-margins stream) + (let ((s-width (bounding-rectangle-width stream)) + (s-height (bounding-rectangle-height stream))) + (if (eq clip-mask :none) + (list left top (- s-width right) (- s-height bottom)) + (let* ((x (pop clip-mask)) + (y (pop clip-mask)) + (width (pop clip-mask)) + (height (pop clip-mask))) + (let ((new-clip-left (max left x)) + (new-clip-top (max top y))) + (list new-clip-left new-clip-top + (- (min (+ left (- s-width right)) ;clip-right + (+ x width)) ;another clip-right + new-clip-left) + (- (min (+ top (- s-height bottom)) ;clip-bottom + (+ y height)) ;another clip-bottom + new-clip-top)))))))) + +;; This is necessary because the GC used for drawing doesn't depend only +;; on the ink used, unfortunately. We have to adjust the clip-mask for +;; the stream it's used on. +(defmethod clx-decode-ink :around (ink stream) + (setq ink (call-next-method)) + (with-slots (clip-mask) stream + (setf (xlib:gcontext-clip-mask ink) + #---ignore clip-mask + #+++ignore (compute-gcontext-clip-mask stream clip-mask))) + ink) + +;; This only needs to be called for shapes, not points or characters. +;; Basically, we want to do things in here that operate on cached inks +;; (graphics contexts). +(defmethod clx-adjust-ink (ink stream line-style) + (with-slots (points-to-pixels) stream + (when (eq (xlib:gcontext-fill-style ink) :tiled) + (with-bounding-rectangle* (left top right bottom) (window-viewport stream) + (declare (ignore right bottom)) + (let ((size (xlib:drawable-width (xlib:gcontext-tile ink)))) + (setf (xlib:gcontext-ts-x ink) (mod left size) ;--- 16 is a magic + (xlib:gcontext-ts-y ink) (mod top size))))) + (when line-style + (let ((thickness (line-style-thickness line-style))) + (ecase (line-style-unit line-style) + ((:normal :point) + (setf thickness (* thickness points-to-pixels)))) + (setf (xlib:gcontext-line-width ink) + (if (< thickness 2) 0 (round thickness))) + (let ((dashes (line-style-dashes line-style))) + (cond (dashes + (setf (xlib:gcontext-line-style ink) :dash) + (setf (xlib:gcontext-dashes ink) + #-Allegro (cond ((eq dashes t) #(4 4)) + ((listp dashes) (coerce dashes 'vector)) + (t dashes)) + #+Allegro (cond ((eq dashes t) '(4 4)) + ((vectorp dashes) (coerce dashes 'list)) + (t dashes)))) + (t + (setf (xlib:gcontext-line-style ink) :solid)))) + (setf (xlib:gcontext-cap-style ink) + (ecase (line-style-cap-shape line-style) + (:butt :butt) + (:square :projecting) + (:round :round) + (:no-end-point :not-last))) + (setf (xlib:gcontext-join-style ink) + (ecase (line-style-joint-shape line-style) + ((:miter :none) :miter) + (:bevel :bevel) + (:round :round))))) + ink)) + + +;;; Drawing functions + +(defmethod draw-point-internal ((stream clx-window) x-offset y-offset x y ink line-style) + (fix-points x y) + (translate-positions x-offset y-offset x y) + (with-slots (window points-to-pixels) stream + (let ((thickness (line-style-thickness line-style)) + (gc (clx-decode-ink ink stream))) + (ecase (line-style-unit line-style) + ((:normal :point) + (setf thickness (* thickness points-to-pixels)))) + (if (< thickness 2) + (xlib:draw-point window gc x y) + (let ((thickness (round thickness))) + (xlib:draw-arc window gc x y thickness thickness 0 2pi t))))) + (clx-force-output-if-necessary stream)) + +(defmethod draw-line-internal ((stream clx-window) x-offset y-offset + start-x start-y end-x end-y ink line-style) + (fix-points start-x end-x start-y end-y) + (translate-positions x-offset y-offset start-x start-y end-x end-y) + (with-slots (window) stream + (xlib:draw-line window + (clx-adjust-ink (clx-decode-ink ink stream) stream line-style) + start-x start-y end-x end-y)) + (clx-force-output-if-necessary stream)) + +(defmethod draw-rectangle-internal ((stream clx-window) x-offset y-offset + left top right bottom ink line-style) + (fix-points left top right bottom) + (translate-positions x-offset y-offset left top right bottom) + (with-slots (window) stream + (xlib:draw-rectangle window + (clx-adjust-ink (clx-decode-ink ink stream) stream line-style) + left top (- right left) (- bottom top) (null line-style))) + (clx-force-output-if-necessary stream)) + +(defmethod draw-polygon-internal ((stream clx-window) x-offset y-offset + list-of-x-and-ys closed ink line-style) + (setq list-of-x-and-ys + (mapcar #'round (translate-point-sequence x-offset y-offset list-of-x-and-ys))) + (let ((points list-of-x-and-ys)) + (when (and closed line-style) ;kludge + (setq points (append points `(,(first points) ,(second points))))) + (with-slots (window) stream + (xlib:draw-lines window + (clx-adjust-ink (clx-decode-ink ink stream) stream line-style) + points :fill-p (null line-style)))) + (clx-force-output-if-necessary stream)) + +(defmethod draw-ellipse-internal ((stream clx-window) x-offset y-offset + center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) + (fix-points center-x center-y) + (translate-positions x-offset y-offset center-x center-y) + (when (null start-angle) + (setq start-angle 0.0 + end-angle 2pi)) + ;; Awaiting implementation of real graphics model + ;; CLX takes a start angle and a delta-angle relative to it, but measures angles + ;; such that pi/2 points straight up even though Y increases downwards. Flip that. + (setq start-angle (- 2pi start-angle) + end-angle (- 2pi end-angle)) + ;; We also have to flip the sense of clockwise. + (rotatef start-angle end-angle) + ;; The caller has already coerced start- and end-angle to be in the range 0 <= angle < 2pi + (when (< end-angle start-angle) + (setq end-angle (+ end-angle 2pi))) + (setf radius-1-dx (round radius-1-dx)) + (setf radius-1-dy (round radius-1-dy)) + (setf radius-2-dx (round radius-2-dx)) + (setf radius-2-dy (round radius-2-dy)) + (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))))))) + (with-slots (window) stream + (let ((angle-size (- end-angle start-angle))) + (xlib:draw-arc window + (clx-adjust-ink (clx-decode-ink ink stream) stream line-style) + (- center-x x-radius) (- center-y y-radius) + (* x-radius 2) (* y-radius 2) + ;; CLX measures the second angle relative to the first + start-angle angle-size (null line-style))))) + (clx-force-output-if-necessary stream)) + + +;;; Character-drawing methods for CLX implementation + +;; TEXT-STYLE must be a fully merged text style +(defmethod stream-glyph-for-character + ((stream clx-window) character text-style &optional our-font) + (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y)) + (with-slots (window display-device-type) stream + (multiple-value-bind (character-set index) + (char-character-set-and-index character) + (when (eql character-set *standard-character-set*) + (setf index (xlib:char->card8 character))) ;A little gross, but right, I think. + (let* ((x-font (or our-font + (text-style-mapping + display-device-type character-set text-style window))) + (escapement-x (or (xlib:char-width x-font index) + ;;--- Sometimes the above can return NIL + (xlib:char-width x-font (xlib:char->card8 #\A)))) + (escapement-y 0) + (origin-x 0) + (origin-y (xlib:font-ascent x-font)) + (bb-x escapement-x) + (bb-y (+ origin-y (xlib:font-descent x-font)))) + (values index x-font escapement-x escapement-y origin-x origin-y bb-x bb-y))))) + +(defmethod stream-write-char-1 ((stream clx-window) index x-font ink x y) + (with-slots (window) stream + (let ((gc (clx-decode-ink ink stream))) + (setf (xlib:gcontext-font gc) x-font) + ;; Move line down so that the top of the character (not the baseline) is at Y. + (xlib:draw-glyph window gc (round x) (+ (round y) (xlib:font-ascent x-font)) index))) + (clx-force-output-if-necessary stream)) + +(defmethod stream-write-string-1 ((stream clx-window) + glyph-buffer start end x-font ink x y) + ;;--- For some reason we can get into a state when start = end meaning + ;;--- there is nothing to draw and font is NIL so lets skip doing + ;;--- anything - cer + (when (> end start) + (with-slots (window) stream + (let ((size (if (find-if #'(lambda (x) (> x 255.)) glyph-buffer :start start :end end) + 16 :default)) + (gc (clx-decode-ink ink stream))) + (setf (xlib:gcontext-font gc) x-font) + ;; Move line down so that the top of the characters (not the baseline) is at Y. + (xlib:draw-glyphs window gc (round x) (+ (round y) (xlib:font-ascent x-font)) + glyph-buffer + :start start :end end :translate #'noop-translate-function + :size size))) + (clx-force-output-if-necessary stream))) + +;;; Too bad we have to copy the glyphs again, but that's life... +(defun noop-translate-function (src src-start src-end font dst dst-start) + (declare (values ending-index horizontal-motion width)) + (declare (ignore font)) + (replace dst src :start1 dst-start :start2 src-start :end2 src-end) + (values src-end nil nil)) + +(defmethod clx-get-default-font ((stream clx-window)) + (with-slots (window display-device-type) stream + (text-style-mapping + display-device-type *standard-character-set* (stream-merged-text-style stream) window))) + +(defmethod draw-string-internal ((stream clx-window) x-offset y-offset + string x y start end align-x align-y text-style ink) + (fix-points x y) + (translate-positions x-offset y-offset x y) + (with-slots (window display-device-type) stream + (let* ((font (if text-style + (text-style-mapping + display-device-type *standard-character-set* text-style window) + (clx-get-default-font stream))) + (ascent (xlib:font-ascent font)) + (descent (xlib:font-descent font)) + (height (+ ascent descent)) + (gc (clx-decode-ink ink stream))) + (incf x (compute-text-x-adjustment + align-x stream string text-style start end)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + (setf (xlib:gcontext-font gc) font) + (xlib:draw-glyphs window gc x y string :start start :end end))) + (clx-force-output-if-necessary stream)) + +(defmethod draw-character-internal ((stream clx-window) x-offset y-offset + character x y align-x align-y text-style ink) + (fix-points x y) + (translate-positions x-offset y-offset x y) + (with-slots (window display-device-type) stream + (let* ((font (if text-style + (text-style-mapping + display-device-type *standard-character-set* text-style window) + (clx-get-default-font stream))) + (ascent (xlib:font-ascent font)) + (descent (xlib:font-descent font)) + (height (+ ascent descent)) + (gc (clx-decode-ink ink stream))) + (incf x (compute-text-x-adjustment + align-x stream character text-style)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + (setf (xlib:gcontext-font gc) font) + (xlib:draw-glyph window gc x y character))) + (clx-force-output-if-necessary stream)) + + +(defmethod text-style-height ((text-style standard-text-style) (stream clx-window)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (let* ((ascent (xlib:font-ascent font)) + (descent (xlib:font-descent font)) + (height (+ ascent descent))) + height)))) + +(defmethod text-style-width ((text-style standard-text-style) (stream clx-window)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + ;; Disgusting, but probably OK + (xlib:char-width font (xlib:char->card8 #\A))))) + +(defmethod text-style-ascent ((text-style standard-text-style) (stream clx-window)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (xlib:font-ascent font)))) + +(defmethod text-style-descent ((text-style standard-text-style) (stream clx-window)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (xlib:font-descent font)))) + +(defmethod text-style-fixed-width-p ((text-style standard-text-style) (stream clx-window)) + (with-slots (window display-device-type) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + ;; Really disgusting, but probably OK + (= (xlib:char-width font (xlib:char->card8 #\.)) + (xlib:char-width font (xlib:char->card8 #\M)))))) + +(defmethod text-size ((stream clx-window) string + &key (text-style (stream-merged-text-style stream)) (start 0) end) + (when (characterp string) + (setq string (string string) + start 0 + end nil)) + (multiple-value-bind (last-x largest-x last-y total-height baseline) + (stream-string-output-size stream string :text-style text-style :start start :end end) + (values largest-x total-height last-x last-y baseline))) + + + +(defun create-clx-root-window (&rest args) + (declare (dynamic-extent args)) + (apply #'make-instance 'clx-root-window args)) + +(define-implementation :clx 'create-clx-root-window) + diff --git a/pre-silica/default-application.lisp b/pre-silica/default-application.lisp new file mode 100644 index 00000000..b4dede10 --- /dev/null +++ b/pre-silica/default-application.lisp @@ -0,0 +1,204 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: default-application.lisp,v 1.4 91/03/26 12:47:50 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +(define-application-frame default-application () () + (:command-definer nil)) + +;;; These are DEFVARs in clim-defs.lisp +(setq *default-application* (make-application-frame 'default-application)) + +;;--- Is it really necessary for this to have a global value? +(setq *application-frame* *default-application*) + +(defmethod frame-input-context-button-press-handler + ((frame standard-application-frame) stream button-press-event) + (declare (ignore stream)) + (let* ((window (event-window button-press-event)) + (x (pointer-event-x button-press-event)) + (y (pointer-event-y button-press-event)) + (highlighted-presentation (highlighted-presentation window nil)) + (input-context *input-context*)) + (when highlighted-presentation + ;; Unhighlight on the way out. + ;; But only unhighlight the window that the click is from. + (unhighlight-highlighted-presentation window nil)) + (throw-highlighted-presentation + (or (and (output-recording-stream-p window) + (frame-find-innermost-applicable-presentation + frame input-context window x y)) + *null-presentation*) + input-context + button-press-event))) + +;;; The contract of this is to find an "appropriate" presentation; i.e., one +;;; satisfying the input context specified by TYPE. Everything that looks for a +;;; presentation goes through this so that applications can specialize it. +(defmethod frame-find-innermost-applicable-presentation + ((frame standard-application-frame) input-context stream x y) + (find-innermost-applicable-presentation input-context stream x y)) + +;;; The contract of this is to replay the contents of STREAM within the region. +(defmethod frame-replay ((frame standard-application-frame) stream &optional region) + (stream-replay stream region) + (force-output stream)) + + +(defvar *pointer-documentation-interval* + (max (floor (* 1/10 internal-time-units-per-second)) 1)) +(defvar *last-pointer-documentation-time* 0) + +#+Genera +(defvar *pointer-documentation-buffer* + (make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t)) + +;;; Produce pointer documentation +(defmethod frame-document-highlighted-presentation + ((frame standard-application-frame) presentation input-context window x y stream) + (let (#+Genera (documentation-window (mouse-documentation-window window))) + ;; The documentation should never say anything if we're not over a presentation + (when (null presentation) + #+Genera (if documentation-window + (scl:send documentation-window :clear-window) + (window-clear stream)) + #-Genera (window-clear stream)) + ;; Cheap test to not do this work too often + (let ((old-modifier-state *last-pointer-documentation-modifier-state*) + (modifier-state (window-modifier-state window)) + (last-time *last-pointer-documentation-time*) + (time (get-internal-real-time))) + (setq *last-pointer-documentation-modifier-state* modifier-state) + (when (and (< time (+ last-time *pointer-documentation-interval*)) + (= modifier-state old-modifier-state)) + (return-from frame-document-highlighted-presentation nil)) + (setq *last-pointer-documentation-time* time)) + (when presentation + #+Genera + (when documentation-window + (setf (fill-pointer *pointer-documentation-buffer*) 0) + (with-output-to-string (stream *pointer-documentation-buffer*) + (scl:send documentation-window :clear-window) + (when (null (frame-document-highlighted-presentation-1 + frame presentation input-context window x y stream)) + (setq *last-pointer-documentation-time* 0)) + (scl:send documentation-window :string-out *pointer-documentation-buffer*)) + (return-from frame-document-highlighted-presentation nil)) + (with-output-recording-options (stream :record nil) + (with-end-of-line-action (stream :allow) + (with-end-of-page-action (stream :allow) + (window-clear stream) + (when (null (frame-document-highlighted-presentation-1 + frame presentation input-context window x y stream)) + (setq *last-pointer-documentation-time* 0)) + (force-output stream))))))) + +(defun frame-document-highlighted-presentation-1 + (frame presentation input-context window x y stream) + (let ((modifier-state (window-modifier-state window))) + (declare (fixnum modifier-state)) + (multiple-value-bind (left left-context middle middle-context right right-context) + (find-applicable-translators-for-documentation presentation input-context + frame window x y modifier-state) + (let* ((*print-length* 3) + (*print-level* 2) + (*print-circle* nil) + (*print-array* nil) + (*print-readably* nil) + (*print-pretty* nil)) + (flet ((document-translator (translator context-type button-name separator) + ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS* + (let ((bit #o20) + (shift-name '("h-" "s-" "m-" "c-" "sh-"))) + (declare (fixnum bit)) + (dotimes (i 5) + #-(or Allegro Minima) (declare (ignore i)) + (unless (zerop (logand bit modifier-state)) + (write-string (car shift-name) stream)) + (pop shift-name) + (setq bit (the fixnum (ash bit -1))))) + (write-string button-name stream) + (document-presentation-translator translator presentation context-type + frame nil window x y + :stream stream + :documentation-type :pointer) + (write-string separator stream))) + (declare (dynamic-extent #'document-translator)) + (when left + (let ((button-name (cond ((and (eql left middle) + (eql left right)) + (setq middle nil + right nil) + "L,M,R: ") + ((eql left middle) + (setq middle nil) + "L,M: ") + (t "L: ")))) + (document-translator left left-context button-name + (if (or middle right) "; " ".")))) + (when middle + (let ((button-name (cond ((eql middle right) + (setq right nil) + "M,R: ") + (t "M: ")))) + (document-translator middle middle-context button-name + (if right "; " ".")))) + (when right + (document-translator right right-context "R: " ".")) + ;; Return non-NIL if any pointer documentation was produced + (or left middle right)))))) + +;; This is derived directly from FIND-APPLICABLE-TRANSLATORS +(defun find-applicable-translators-for-documentation + (presentation input-context frame window x y modifier-state) + ;; Assume a maximum of three pointer buttons + (let ((left nil) (left-context nil) + (middle nil) (middle-context nil) + (right nil) (right-context nil)) + (macrolet ((match (translator context-type button) + (let ((button-translator (intern (symbol-name button))) + (button-context (fintern "~A-~A" (symbol-name button) 'context))) + `(when (and (or (null ,button-translator) + (> (presentation-translator-priority ,translator) + (presentation-translator-priority ,button-translator))) + (button-and-modifier-state-matches-gesture-name + (button-index ,button) modifier-state + (presentation-translator-gesture-name ,translator))) + (setq ,button-translator ,translator + ,button-context ,context-type))))) + (do ((presentation presentation + (parent-presentation-with-shared-box presentation window))) + ((null presentation)) + (let ((from-type (presentation-type presentation))) + (dolist (context input-context) + (let ((context-type (pop context))) ;input-context-type = first + (let ((translators (find-presentation-translators + from-type context-type (frame-command-table frame)))) + (when translators + (dolist (translator translators) + (when (test-presentation-translator translator + presentation context-type + frame window x y + :modifier-state modifier-state) + (match translator context-type :left) + (match translator context-type :middle) + (match translator context-type :right))))) + (when (and (or left middle right) + *presentation-menu-translator* + (test-presentation-translator *presentation-menu-translator* + presentation context-type + frame window x y + :modifier-state modifier-state)) + (match *presentation-menu-translator* context-type :left) + (match *presentation-menu-translator* context-type :middle) + (match *presentation-menu-translator* context-type :right))))))) + (values left left-context + middle middle-context + right right-context))) + +#+Genera +(defmethod mouse-documentation-window ((window window-stream)) nil) diff --git a/pre-silica/define-application.lisp b/pre-silica/define-application.lisp new file mode 100644 index 00000000..9780aeb8 --- /dev/null +++ b/pre-silica/define-application.lisp @@ -0,0 +1,1287 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: define-application.lisp,v 1.4 91/03/26 12:47:50 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +(defvar *window-stream-to-frame-table* (make-hash-table)) + +(defun-inline window-stream-to-frame (window-stream) + (gethash window-stream *window-stream-to-frame-table*)) + +(defun create-application-frame (frame &rest args) + (declare (dynamic-extent args)) + (let* ((window-stream + (apply #'open-window-stream args))) + (setf (gethash window-stream *window-stream-to-frame-table*) frame) + window-stream)) + +(define-protocol-class application-frame ()) + +(defclass standard-application-frame + (application-frame) + ((name :initarg :name :accessor frame-name) + (pretty-name :initarg :pretty-name :accessor frame-pretty-name) + (current-layout :initarg :current-layout + :reader frame-current-layout) + (top-level-sheet :initarg :top-level-sheet :initform nil + :accessor frame-top-level-sheet) + (panes :initarg panes :initform nil :accessor frame-panes) + ;; This is a copy of what's in the frame-descriptor, so that local + ;; state can be cached here. It's length and order matches PANES. + (pane-descriptions :initarg :pane-descriptions :initform nil) + ;; The real panes in the current layout + (current-panes :initform nil :accessor frame-current-panes) + (initialized-panes :initform nil) + (command-table :initarg :command-table :initform nil + :accessor frame-command-table) + (disabled-commands :initarg :disabled-commands :initform nil) + ;; A slot for per-application histories + (histories :initform nil))) + +#+CLIM-1-compatibility +(define-compatibility-function (frame-top-level-window frame-top-level-sheet) + (frame) + (frame-top-level-sheet frame)) + +(defmethod (setf frame-pretty-name) :after (name (frame standard-application-frame)) + (with-slots (top-level-sheet) frame + (when #+Genera (not (typep top-level-sheet 'sheet-implementation-mixin)) + #-Genera t + (setf (window-label top-level-sheet) name)))) + +(eval-when (eval compile load) + +(defstruct (frame-descriptor (:print-function print-frame-descriptor)) + name + state-variables + state-variable-names + pane-descriptions + layout + top-level + command-table + disabled-commands) + +(defun print-frame-descriptor (descriptor stream depth) + (declare (ignore depth)) + (print-unreadable-object (descriptor stream :type t :identity t) + (write (frame-descriptor-name descriptor) :stream stream :escape nil))) + +;; Where is the LIST* DEFSTRUCT type when we need it? +(defun-inline pane-descriptor-name (pane-descriptor) (first pane-descriptor)) +(defun-inline pane-descriptor-type (pane-descriptor) (second pane-descriptor)) +(defun-inline pane-descriptor-options (pane-descriptor) (cddr pane-descriptor)) +(defsetf pane-descriptor-options (pane-descriptor) (new-value) + `(setf (cddr ,pane-descriptor) ,new-value)) + +(defvar *frame-descriptors* nil) + +(defun collect-state-variable-names (state-variables) + (let ((names nil)) + (dolist (var state-variables) + (cond ((atom var) (push var names)) + (t (push (first var) names)))) + (nreverse names))) + +(defun construct-default-layout (pane-descriptions) + (let ((the-layout nil)) + (dolist (entry pane-descriptions) + (let ((window-name (pane-descriptor-name entry)) + (default-size (getf (pane-descriptor-options entry) :default-size ':rest))) + (push `(,window-name ,default-size) the-layout))) + `((main (:column :rest ,@(nreverse the-layout)))))) + +(defun define-application-frame-1 (name state-variables pane-descriptions + &key top-level layout + command-table disabled-commands) + (unless layout + (setq layout (construct-default-layout pane-descriptions))) + (let* ((state-variable-names (collect-state-variable-names state-variables)) + (command-table-name (first command-table)) + (frame-descriptor + (make-frame-descriptor :name name + :state-variables state-variables + :state-variable-names state-variable-names + :pane-descriptions pane-descriptions + :layout layout + :top-level top-level + :command-table command-table-name + :disabled-commands disabled-commands))) + (push-unique frame-descriptor *frame-descriptors* + :key #'frame-descriptor-name) + ;; If we're going to be defining commands for this application frame, + ;; make sure there's an command table lying around so that all other + ;; code doesn't have to be defensive against its absence. + (when command-table + (apply #'define-command-table-1 command-table)) + frame-descriptor)) + +(defun find-frame-descriptor (frame) + (when (application-frame-p frame) + (setq frame (frame-name frame))) + (find frame *frame-descriptors* :key #'frame-descriptor-name)) + +) + +(defmacro define-application-frame (name superclasses slots &rest options) + #+Genera (declare (zwei:indentation 1 25 2 3 3 1)) + (with-warnings-for-definition name define-application-frame + (let (panes layout top-level command-definer command-table disabled-commands) + (macrolet ((extract (name keyword default) + `(let ((entry (assoc ',keyword options))) + (cond ((null entry) + (setq ,name ,default)) + (t + (assert (= (length entry) 2) (entry) + "The length of the option ~S must be 2" entry) + (setq ,name (second entry) + options (delete entry options))))))) + (extract panes :panes nil) + (extract layout :layout nil) + (extract top-level :top-level '(default-frame-top-level)) + (extract command-definer :command-definer t) + (extract command-table :command-table t) + (extract disabled-commands :disabled-commands nil)) + (check-type name symbol) + (check-type superclasses list) + (check-type slots list) + (check-type panes list) + (check-type layout list) + (check-type top-level list) + (check-type disabled-commands list) + (let* ((pane-descriptions (produce-pane-descriptions panes))) + (when (null superclasses) + (setq superclasses '(standard-application-frame))) + (when (eq command-definer 't) + (setq command-definer (fintern "~A-~A-~A" 'define name 'command))) + (check-type command-definer symbol) + (cond ((null command-table)) + ((symbolp command-table) + (setq command-table (list command-table))) + (t (warn-if-command-table-invalid name command-table))) + (when (eq (first command-table) 't) + (setq command-table (list* name (rest command-table)))) + (warn-if-pane-descriptions-invalid name pane-descriptions) + (warn-if-layout-invalid name layout pane-descriptions) + ;; The pane descriptions is really a form that evaluates to be the + ;; pane decriptions, but it's easier to deal with in the "raw" form. + ;; A little extra consing at compile-time won't kill us. + (setq pane-descriptions + `(list ,@(mapcar #'(lambda (desc) + (let ((name (first desc)) + (type (second desc)) + (options (cddr desc))) + `(list ',name ',type ,@options))) + pane-descriptions))) + `(progn + (eval-when (compile) + (when ',command-table + (setf (compile-time-property ',(first command-table) 'command-table-name) t)) + (define-application-frame-1 ',name ',slots ,pane-descriptions + :layout ',layout + :top-level ',top-level + :command-table ',command-table)) + (define-group ,name define-application-frame + (defclass ,name ,superclasses ,slots ,@options) + ,@(when command-definer + `((defmacro ,command-definer (command-name arguments &body body) + #+Genera (declare (zwei:indentation 1 3 2 1)) + `(define-frame-command ,',(first command-table) + ,command-name ,arguments ,@body)) + #+Genera (scl:defprop ,command-definer + define-command + zwei:definition-function-spec-type) + #+Genera (scl:defprop ,command-definer + remove-command + zwei:kill-definition) + #+Genera (scl:defprop ,command-definer + zwei:defselect-function-spec-finder + zwei:definition-function-spec-finder))) + (define-application-frame-1 ',name ',slots ,pane-descriptions + :layout ',layout + :top-level ',top-level + :command-table ',command-table + :disabled-commands ',disabled-commands) + #+Cloe-Runtime + (cloe:define-program ,name () + :main ,name + :debugger-hook cloe-debugger-hook))))))) + +#+Genera +(scl:defprop define-application-frame "CLIM Application Frame" si:definition-type-name) + +;; For now each application frame has its own command table named after the application +(defmacro define-frame-command (command-table-name name-and-options arguments &body body) + #+Genera (declare (zwei:indentation 2 3 3 1)) + (multiple-value-bind (command-name command-options) + (decode-name-and-options name-and-options command-table-name) + `(define-command (,command-name :command-table ,command-table-name ,@command-options) + ,arguments + ,@body))) + +#+Genera +(scl::defprop define-frame-command define-command zwei:definition-function-spec-type) +#+Genera +(scl:defun (:property define-frame-command zwei:definition-function-spec-finder) (bp) + (zwei:defselect-function-spec-finder (zwei:forward-sexp bp 1 t))) + +#+CLIM-1-compatibility +(defmacro with-frame-state-variables + ((frame-name &optional (frame '*application-frame*)) &body body) + ;; frame descriptor must be findable at compile-time + (let* ((descriptor (find-frame-descriptor frame-name)) + (state-variables (frame-descriptor-state-variable-names descriptor))) + `(with-slots ,state-variables ,frame ,@body))) + +(defun warn-if-command-table-invalid (frame-name command-table) + (cond ((not (and (listp command-table) + (symbolp (first command-table)) + (oddp (length command-table)))) + (warn "The :COMMAND-TABLE option for frame ~S, ~S, is invalid.~@ + It is supposed to be a list of a command table name followed by ~ + keyword/value pairs." + frame-name command-table)) + (t + (do* ((options (cdr command-table) (cddr options)) + (keyword (first options) (first options)) + (value (second options) (second options))) + ((null options)) + (case keyword + (:inherit-from + (if (listp value) + (dolist (item value) + (unless (typep item '(or symbol command-table)) + (warn "The :INHERIT-FROM keyword in the :COMMAND-TABLE option for ~ + frame ~S~@ + is followed by a list containing ~S, which is not a ~ + command table nor a command table name." + frame-name item))) + (warn "The :INHERIT-FROM keyword in the :COMMAND-TABLE option for ~ + frame ~S~@ + is followed by ~S, which is not a list of command tables ~ + or command table names." + frame-name value))) + (:menu + (if (listp value) + (dolist (clause value) + (unless (and (listp clause) + (>= (length clause) 3) + (oddp (length clause)) + (stringp (first clause)) + (member (second clause) + '(:command :function :menu :divider))) + (warn "The :MENU keyword in the :COMMAND-TABLE option for frame ~S~@ + is followed by a list of menu clauses containing~@ + an invalid clause ~S." + frame-name clause))) + (warn "The :MENU keyword in the :COMMAND-TABLE option for frame ~S~@ + is followed by ~S, which is not a list of menu clauses." + frame-name value))) + (otherwise + (warn "The keyword ~S in the :COMMAND-TABLE option for frame ~S is invalid.~@ + The valid keywords are :INHERIT-FROM and :MENU." + keyword frame-name))))))) + +;;; The args just get passed through to the specific application. +(defun make-application-frame (frame-name &rest args + &key frame-class pretty-name &allow-other-keys) + (declare (arglist frame-name + &key frame-class pretty-name + ;; initargs to application-frame that are + ;; not supplied in the make-instance below + parent left top right bottom height width + ;panes ;i don't think we want to mention this + ;top-level-sheet ;.. + ;; this is here because application frame classes + ;; can define additional initialization arguments, + ;; so we can't predict the full set of keyword + ;; arguments allowed in a particular call. + &allow-other-keys)) + (declare (dynamic-extent args)) + (check-type pretty-name (or null string)) + (let* ((descriptor (find-frame-descriptor frame-name)) + pane-descriptions current-layout) + (assert descriptor nil "unknown application frame: ~s" frame-name) + (setq pane-descriptions (frame-descriptor-pane-descriptions descriptor) + current-layout (caar (frame-descriptor-layout descriptor))) + (when (null frame-class) (setq frame-class frame-name)) + (with-keywords-removed (new-args args '(:frame-class :pretty-name)) + (apply #'make-instance frame-class + :name frame-name + :pretty-name (or pretty-name + (getf (pane-descriptor-options + (find :title pane-descriptions + :key #'pane-descriptor-type)) + :display-string) + (title-capitalize (string frame-name))) + :pane-descriptions (copy-tree pane-descriptions) + :current-layout current-layout + :command-table (frame-descriptor-command-table descriptor) + :disabled-commands (copy-list (frame-descriptor-disabled-commands descriptor)) + new-args)))) + +;;; PANE-TYPE-OPTIONS is how you define a new pane type. +(defmethod pane-type-options ((type (eql :command-menu))) + `(:default-text-style *command-table-menu-text-style* + :incremental-redisplay t + :display-function 'display-command-menu + :display-after-commands t + :default-size :compute + :scroll-bars nil)) + +;;--- Should this use incremental redisplay? +(defmethod pane-type-options ((type (eql :title))) + `(:default-text-style (parse-text-style '(:sans-serif :bold :very-large)) + :display-function 'display-title + :display-after-commands nil + :default-size :compute + :scroll-bars nil)) + +(defmethod pane-type-options ((type (eql :interactor))) + `(:scroll-bars :vertical + :initial-cursor-visibility :off)) + +(defmethod pane-type-options ((type (eql :application))) + `(:default-size :rest)) + +(defmethod pane-type-options ((type (eql :pointer-documentation))) + `(:default-text-style (parse-text-style '(:sans-serif :bold :normal)) + :display-after-commands nil + :default-size :compute + :scroll-bars nil)) + +(defun produce-pane-descriptions (panes) + (let ((descriptions nil)) + (dolist (window-info panes (nreverse descriptions)) + ;; We really need destructuring-bind, but until there are options we can wait + (let ((name (first window-info)) + (type (second window-info)) + (options (cddr window-info))) + (push `(,name ,type ,@options ,@(pane-type-options type)) descriptions))))) + +(defun-inline dummy-pane-p (pane) + (symbolp pane)) + +(defvar *non-window-pane-keywords* + '(:width :height :default-size :height-in-lines + :display-after-commands :incremental-redisplay + :display-function :display-string :save-under)) + +;;; This function simply creates a bunch of windows with dummy size. +;;; LAYOUT-FRAME-PANES actually does the laying out of the windows. +(defun create-windows-from-description (frame descriptions root + &key left top right bottom width height + save-under) + (when descriptions ;suppose no windows... + (let ((p-left 0) (p-top 0) (p-right nil) (p-bottom nil)) + (multiple-value-setq (p-right p-bottom) + (window-inside-size root)) + ;; This is the same definition as is macroleted in open-window-stream. You + ;; could argue that it should be pulled out and published. + (macrolet ((rationalize-dimensions (low high delta direction) + (flet ((parent-name (name) (fintern "~A-~A" 'p name))) + (let ((p-low (parent-name low)) + (p-high (parent-name high))) + `(progn + (assert (not (and ,low ,high ,delta + (/= ,delta (- ,high ,low)))) + (,low ,high ,delta) + ,(format + nil + "The ~A dimensions of this window are overconstrained." + direction)) + (when ,low (setf ,p-low ,low)) + (when ,high (setf ,p-high ,high)) + (when ,delta (if ,high + (setf ,p-low (- ,p-high ,delta)) + (setf ,p-high (+ ,p-low ,delta)))) + (setf ,low ,p-low ,high ,p-high ,delta (- ,p-high ,p-low))))))) + (rationalize-dimensions left right width "horizontal") + (rationalize-dimensions top bottom height "vertical"))) + (let* ((genera-p #+Genera (typep root 'sheet-window-stream) + #-Genera nil) + ;; On non-Genera window systems, use the title bar that those window + ;; systems provide instead of a title pane. + (title-pane-p (and genera-p + (find :title descriptions :key #'pane-descriptor-type))) + ;; On Genera, only label the frame if there is no title pane. On other + ;; window systems, the label will appear in the title bar. + (label (if genera-p + (if title-pane-p nil (frame-pretty-name frame)) + (frame-pretty-name frame))) + ;; Only give the frame borders when there is no title pane. + (borders (not title-pane-p)) + (main (create-application-frame frame + :parent root :left left :top top + :width (- right left) :height (- bottom top) + :label label :borders borders + :scroll-bars nil :save-under save-under)) + (input-buffer (stream-input-buffer main)) + (panes nil)) + (dolist (desc descriptions) + (let ((type (pane-descriptor-type desc)) + (options (pane-descriptor-options desc))) + (with-keywords-removed (new-options options *non-window-pane-keywords*) + (cond ((and genera-p (eql type ':pointer-documentation)) + ;; On Genera, use the normal mouse-doc line + (push 'dummy-pointer-documentation-pane panes)) + ((and (not genera-p) (eql type ':title)) + ;; Most window systems put the title in the window decorations + (push 'dummy-title-pane panes)) + (t + (push (apply #'open-window-stream :parent main :left 0 :top 0 + :width 100 :height 100 + :input-buffer input-buffer + new-options) + panes)))))) + (values main (nreverse panes))))) + +(defun warn-if-pane-descriptions-invalid (frame-name descriptions) + (let ((valid-keywords + ;; We will instantiate a port-dependent subclass of this class, but we only care + ;; about initialization arguments that are accepted by all subclasses. + (let ((class (find-class 'window-stream))) + ;; It's probably a bug that class-make-instance-keywords doesn't do this itself + #+(or Genera Cloe-Runtime) (unless (clos-internals::class-finalized-p class) + (clos-internals::finalize-inheritance class)) + ;; In Symbolics CLOS this function returns the initialization arguments accepted + #+(or Genera Cloe-Runtime) (clos-internals::class-make-instance-keywords class) + ;; There is no standard for this, so in systems where we don't know how to do it, + ;; just punt. + #-(or Genera Cloe-Runtime) (return-from warn-if-pane-descriptions-invalid nil))) + (non-window-keywords *non-window-pane-keywords*)) + (dolist (desc descriptions) + (let (;; Surprisingly, the valid options don't depend on the pane type + ;(type (pane-descriptor-type desc)) + (options (pane-descriptor-options desc)) + (invalid-keywords nil)) + (do* ((options options (cddr options)) + (keyword (car options) (car options))) + ((null options)) + (unless (or (eql keyword ':window-class) + (member keyword non-window-keywords) + (member keyword valid-keywords)) + (push keyword invalid-keywords))) + (when invalid-keywords + (setq invalid-keywords (nreverse invalid-keywords)) + (warn "The option~P ~{~S~^, ~}~@ + specified for pane ~S of frame ~S ~:[is~;are~] not valid.~@ + Known options are ~S." + (length invalid-keywords) invalid-keywords + (pane-descriptor-name desc) frame-name (cdr invalid-keywords) + (sort (append valid-keywords non-window-keywords '(:window-class) nil) + #'string<))))))) + +(defvar *frame-layout-changing-p* nil) + +;;; This used to be an after method, unconditionally setting the layout. +;;; Now, make it an around method that only recomputes the layout if the size changes, +;;; not if only the position changes. (Eliminates some unnecessary redisplays.) +#-Silica +(defmethod window-note-size-or-position-change :around ((window window-mixin) + new-left new-top new-right new-bottom) + (declare (type coordinate new-left new-top new-right new-bottom)) + (multiple-value-bind (width height) (bounding-rectangle-size window) + (declare (type coordinate width height)) + (call-next-method window new-left new-top new-right new-bottom) + (unless (and (= width (- new-right new-left)) + (= height (- new-bottom new-top))) + (let ((frame (window-stream-to-frame window))) + (when frame + (let ((*application-frame* frame)) + (catch 'resynchronize + (let ((*frame-layout-changing-p* t)) + ;; Forcibly layout the frame again + (layout-frame-panes frame (frame-top-level-sheet frame)))))))))) + +(defmethod (setf frame-current-layout) (new-layout (frame standard-application-frame)) + (setq *frame-layout-changing-p* t) + (with-slots (current-panes initialized-panes current-layout) frame + (setf current-layout new-layout) + (layout-frame-panes frame (frame-top-level-sheet frame)) + ;; Forcibly display any panes that have not been displayed yet + (dolist (pane current-panes) + (unless (member pane initialized-panes) + ;; Display the pane and mark it initialized + (redisplay-frame-pane frame pane :force-p t)))) + (unless (eq *application-frame* *default-application*) + ;; must resynchronize even if the layout phase "didn't do anything" + ;; because we might need to get streams rebound, etc. + (throw 'resynchronize T))) + +#+CLIM-1-compatibility +(define-compatibility-function (set-frame-layout (setf frame-current-layout)) + (frame new-layout) + (setf (frame-current-layout frame) new-layout)) + +;; This works in 2 phases. +;; The first phase figures out which windows need to be visible and where +;; the second phase does the work, doing as little as possible. Quite often, +;; the size and position of some windows will not change, and there's no reason +;; to set their visibility to NIL and back to T in that case. +(defmethod layout-frame-panes ((frame standard-application-frame) window-frame) + ;; Some applications have no top-level window. + #-silica + (when window-frame + (let* ((*sizing-application-frame* t) + (descriptor (find-frame-descriptor frame)) + (layout (frame-descriptor-layout descriptor)) + (current-layout (frame-current-layout frame)) + (this-layout (second (assoc current-layout layout)))) + (multiple-value-bind (available-x available-y) + (window-inside-size window-frame) + (let ((windows-and-sizes nil)) + (flet ((size-setter (name left top right bottom) + (setq left (floor left) + top (floor top) + right (floor right) + bottom (floor bottom)) + (let ((pane (get-frame-pane frame name))) + (push (list pane left top right bottom) windows-and-sizes))) + (size-helper (name cluster-type available-width available-height) + (multiple-value-bind (pane description) + (get-frame-pane frame name) + (let ((amount + (if (dummy-pane-p pane) + 0 + (size-frame-pane pane frame + (pane-descriptor-type description) + description + cluster-type + available-width available-height)))) + (cond ((or (keywordp amount) + (dummy-pane-p pane) + (< 0 amount 1)) ;for upward compatibility + amount) + (t + ;; the amount returned by SIZE-FRAME-PANE is inside size + ;; to save SIZE-FRAME-PANE method writers from having to + ;; understand margins. + (multiple-value-bind (lm tm rm bm) + (host-window-margins pane) + (case cluster-type + (:row (+ amount lm rm)) + (:column (+ amount tm bm)))))))))) + (layout-frame-panes-1 this-layout 0 0 available-x available-y + #'size-setter #'size-helper)) + ;; Now windows-and-sizes contains the size and position of each pane + (setq windows-and-sizes (nreverse windows-and-sizes)) + ;; First set the sizes properly + (dolist (element windows-and-sizes) + (let ((pane (pop element))) + (unless (dummy-pane-p pane) + (multiple-value-bind (left top right bottom) + (values-list element) + (with-bounding-rectangle* (pl pt pr pb) pane + (unless (ltrb-equals-ltrb-p pl pt pr pb left top right bottom) + (bounding-rectangle-set-edges pane left top right bottom) + ;; If the size changed, the pane isn't initialized anymore + (setf (slot-value frame 'initialized-panes) + (delete pane (slot-value frame 'initialized-panes))))))))) + ;; Then get the visibilities right + (dolist (inf (window-children window-frame)) + (if (assoc inf windows-and-sizes) + (unless (window-visibility inf) (setf (window-visibility inf) T)) + (when (window-visibility inf) (setf (window-visibility inf) nil)))) + ;; Remember the panes in this layout for later + (setf (frame-current-panes frame) + (delete nil (mapcar #'first windows-and-sizes)))))))) + +(defun layout-frame-panes-1 (layout-spec start-x start-y available-x available-y + size-setter size-helper) + (declare (dynamic-extent size-setter size-helper)) + (setq layout-spec (copy-list layout-spec)) ; so we can modify it + (let ((parent-type (first layout-spec)) + (inferiors (cddr layout-spec)) + (calculated-inferiors nil)) + (dolist (inf inferiors) + (let ((type-or-name (first inf)) + (size-spec (second inf)) + size) + (cond ((eql size-spec :rest) + (setq size ':rest)) + ((eql size-spec :compute) + (setq size (funcall size-helper type-or-name parent-type + available-x available-y))) + ((and (numberp size-spec) + (<= 0 size-spec 1)) + ;; A pane with a relative sizing parameter + (case parent-type + (:row + (setq size (* available-x size-spec))) + (:column + (setq size (* available-y size-spec))))) + (t + (cerror "Compute the size of the pane" + "The size specification ~S is unrecognized" size-spec) + (setq size (funcall size-helper type-or-name parent-type + available-x available-y)))) + ;; Save a copy of this inferior's spec, with the abstract size + ;; spec (e.g. :COMPUTE) replaced by a number. + (let ((entry (copy-list inf))) + (setf (second entry) size) + (push entry calculated-inferiors)))) + (setq calculated-inferiors (nreverse calculated-inferiors)) + (let ((available (case parent-type + (:row available-x) + (:column available-y))) + (n-rests 0)) + ;; Compute left-over space after explicitly-sized panes are allocated + (dolist (inf calculated-inferiors) + (let ((size (second inf))) + (if (eql size ':rest) + (incf n-rests) + (decf available size)))) + (let ((rest-allocation (and (plusp n-rests) (floor available n-rests))) + constant-start adjusted-start constant-size adjusted-size) + ;; Attempt to write code that deals with allocating space along one + ;; dimension (either X or Y) while holding the other dimension constant. + (case parent-type + (:row (setq constant-start start-y + adjusted-start start-x + constant-size available-y)) + (:column (setq constant-start start-x + adjusted-start start-y + constant-size available-x))) + ;; Decode the "adjusted" and "constant" dimensions into actual X and Y + ;; depending on whether we are laying out a row or column + (macrolet ((with-real-coords ((xvar yvar widthvar heightvar) &body body) + `(let (,xvar ,yvar ,widthvar ,heightvar) + (case parent-type + (:row + (setq ,xvar adjusted-start + ,yvar constant-start + ,widthvar adjusted-size + ,heightvar constant-size)) + (:column + (setq ,yvar adjusted-start + ,xvar constant-start + ,heightvar adjusted-size + ,widthvar constant-size))) + ,@body))) + (dolist (inf calculated-inferiors) + (let* ((name-or-type (first inf)) + (size-info (second inf))) + ;; Bite off a chunk for this pane + (setq adjusted-size (if (eql size-info ':rest) + rest-allocation + size-info)) + (with-real-coords (x y width height) + ;; If a sub-row or -column, lay it out + (cond ((keywordp name-or-type) + (layout-frame-panes-1 + inf x y width height size-setter size-helper)) + ;; must be a pane name + (t (funcall size-setter name-or-type x y + (+ x width) (+ y height)))) + ;; Set where the new pane will start. + (incf adjusted-start adjusted-size))))))))) + +(defun warn-if-layout-invalid (frame-name layouts pane-descriptions) + (dolist (layout layouts) + (if (and (listp layout) + (= (length layout) 2) + (symbolp (first layout)) + (listp (second layout)) + (>= (length (second layout)) 3)) + (let ((layout-name (first layout))) + (labels ((check-layout-spec (layout-spec max-remaining) + (unless (and (listp layout-spec) + (>= (length layout-spec) 2)) + (warn "~S appears where either a list of a pane name and size~@ + or a list of :ROW or :COLUMN, size, and inferiors is expected~@ + in layout ~S of frame ~S." + layout-spec layout-name frame-name) + (return-from check-layout-spec max-remaining)) + (let* ((name-or-type (first layout-spec)) + (aggregate (keywordp name-or-type)) + (size-spec (second layout-spec)) + (inferiors (cddr layout-spec))) + ;; Check name-or-type + (if aggregate + (unless (member name-or-type '(:row :column)) + (warn "The keyword ~S appears where :ROW, :COLUMN, or a~@ + pane name is expected, in layout ~S of frame ~S." + name-or-type layout-name frame-name)) + (unless (assoc name-or-type pane-descriptions) + (warn "The undefined pane name ~S appears ~ + in layout ~S of frame ~S." + name-or-type layout-name frame-name))) + ;; Check size-spec + (cond ((eq size-spec :rest)) + ((and (not aggregate) (eq size-spec :compute))) + ((typep size-spec #-Cloe-Runtime '(real 0 1) + #+Cloe-Runtime '(or (rational 0 1) + (float 0 1))) + (decf max-remaining size-spec)) + (aggregate + (warn "The invalid size specification ~S appears in~@ + a ~S entry in layout ~S of frame ~S.~@ + A valid size specification for a row or column is :REST~@ + or a real number between 0 and 1 inclusive." + size-spec name-or-type layout-name frame-name)) + (t + (warn "The invalid size specification ~S appears in~@ + the entry for pane ~S in layout ~S of frame ~S.~@ + A valid size specification for a pane is :REST,~@ + :COMPUTE, or a real number between 0 and 1 inclusive." + size-spec name-or-type layout-name frame-name))) + ;; Check inferiors and check overall plausibility of size-specs + (cond ((not aggregate) + (unless (null inferiors) + (warn "Extra garbage ~S appears after the size specification~@ + in the entry for pane ~S in layout ~S of frame ~S." + inferiors name-or-type layout-name frame-name))) + ((not (consp inferiors)) + (warn "~S appears where a list of inferiors is expected,~@ + after the size specification~@ + in a ~S entry in layout ~S of frame ~S." + inferiors name-or-type layout-name frame-name)) + (t (check-layout-specs name-or-type inferiors))) + max-remaining)) + (check-layout-specs (name-or-type inferiors) + (let ((max-remaining 1) (rest nil)) + (dolist (layout-spec inferiors) + (when (and (listp layout-spec) + (symbolp (second layout-spec))) + (setq rest t)) + (setq max-remaining (check-layout-spec layout-spec max-remaining))) + (cond ((< max-remaining 0) + (warn "~:[The top~;~:*A ~S~] entry in layout ~S of frame ~S~@ + overcommitted the available space by ~S." + name-or-type layout-name frame-name + (- max-remaining))) + ((and rest (= max-remaining 0)) + (warn "~:[The top~;~:*A ~S~] entry in layout ~S of frame ~S~@ + overcommitted the available space. ~ + It didn't leave anything for :REST/:COMPUTE." + name-or-type layout-name frame-name)) + ((and (not rest) (> max-remaining 0)) + (warn "~:[The top~;~:*A ~S~] entry in layout ~S of frame ~S~@ + failed to consume all available space. ~ + The fraction ~S was left over." + name-or-type layout-name frame-name + max-remaining)))))) + (check-layout-specs nil (cdr layout)))) + (warn "~S appears where a list (layout-name (direction 1.0 spec...))~@ + is expected, in the :LAYOUT option of frame ~S." + layout frame-name)))) + +;;; Returns one (1) value, the space taken up along the "available space" dimension. +#-silica +(defmethod size-frame-pane ((window window-mixin) + (frame standard-application-frame) + (type T) ;pane type + pane-description ;description of this window + cluster-type ;horizontal or vertical + available-width available-height) + ;; default method (on T) + pane-description cluster-type available-width available-height + ':rest) + +(defmethod size-frame-pane :around ((window window-mixin) + (frame standard-application-frame) + (type T) + pane-description + cluster-type + available-width available-height) + available-width available-height + (let* ((options (pane-descriptor-options pane-description)) + (nlines (getf options :height-in-lines)) + (vsp (getf options :vertical-spacing (stream-vertical-spacing window))) + (size (call-next-method))) + (case cluster-type + (:row size) + (:column + (if nlines + (if (eql size ':rest) + (+ 5 (* nlines (+ (stream-line-height window) vsp))) + (max size (+ 5 (* nlines (+ (stream-line-height window) vsp))))) + size))))) + +#-silica +(defmethod size-frame-pane ((window window-mixin) + (frame standard-application-frame) + (type (eql :title)) + pane-description + cluster-type + available-width available-height) + available-width available-height + (let* ((options (pane-descriptor-options pane-description)) + (vsp (getf options :vertical-spacing (stream-vertical-spacing window)))) + (case cluster-type + (:row + ;; as wide as the title + ':rest) + (:column + ;; one line in current text style + (+ 5 (+ vsp (stream-line-height window))))))) + +#-silica +(defmethod size-frame-pane ((window window-mixin) + (frame standard-application-frame) + (type (eql :command-menu)) + pane-description + cluster-type + available-width available-height) + ;; Unconstrain the direction along which we are computing the size, so that + ;; the menu will use the constraint in the orthogonal direction to compute + ;; how much space it needs to occupy in this direction + (case cluster-type + (:row (setq available-width nil)) + (:column (setq available-height nil))) + (let* ((options (pane-descriptor-options pane-description)) + (vsp (getf options :vertical-spacing (stream-vertical-spacing window))) + (display-function (getf options :display-function #'display-command-menu)) + (incremental-redisplay (getf options :incremental-redisplay)) + ;; The menu cell for a disabled command is (sometimes) smaller than the + ;; menu cell for an enabled command, so make sure we allocate enough space + (*assume-all-commands-enabled* t) + (command-table (getf options :command-table)) + (displayer (if incremental-redisplay + #'call-redisplay-function + #'call-display-function)) + (menu-contents + (with-output-to-output-record (window) + (if command-table + (funcall displayer display-function frame window + :command-table command-table + :max-width available-width + :max-height available-height) + (funcall displayer display-function frame window + :max-width available-width + :max-height available-height))))) + (multiple-value-bind (width height) (bounding-rectangle-size menu-contents) + (case cluster-type + (:row width) + (:column (+ height vsp)))))) + +#-silica +(defmethod size-frame-pane ((window window-mixin) + (frame standard-application-frame) + (type (eql :application)) + pane-description + cluster-type + available-width available-height) + available-width available-height + ;;--- This might want to see if the window already has stuff in it, no? + ;;--- The display-function needs to produce a meaningful result when + ;;--- the application frame is created. + (let* ((options (pane-descriptor-options pane-description)) + (display-function (getf options :display-function)) + (incremental-redisplay (getf options :incremental-redisplay))) + (if display-function + (let ((window-contents + (with-output-to-output-record (window) + (funcall (if incremental-redisplay + #'call-redisplay-function + #'call-display-function) + display-function frame window)))) + (multiple-value-bind (width height) + (bounding-rectangle-size window-contents) + (case cluster-type + (:row width) + (:column height)))) + ':rest))) + +#-silica +(defmethod size-frame-pane ((window window-mixin) + (frame standard-application-frame) + (type (eql :pointer-documentation)) + pane-description + cluster-type + available-width available-height) + available-width available-height + (let* ((options (pane-descriptor-options pane-description)) + (vsp (getf options :vertical-spacing (stream-vertical-spacing window)))) + (case cluster-type + (:row + ;; as wide as the title + ':rest) + (:column + ;; one line in current text style + (+ 2 (+ vsp (stream-line-height window))))))) + +(defmethod initialize-instance :after ((frame standard-application-frame) + &key pane-descriptions parent + left top right bottom width height) + ;; If parent is NIL, assume that the caller of MAKE-APPLICATION-FRAME is going + ;; to take care of window initialization. + (when parent + (multiple-value-bind (main-window panes) + (create-windows-from-description frame pane-descriptions parent + :left left :top top + :right right :bottom bottom + :width width :height height) + (setf (slot-value frame 'top-level-sheet) main-window) + (setf (slot-value frame 'panes) panes) + (let ((*application-frame* frame)) + (layout-frame-panes frame main-window))))) + +(defun get-frame-pane (frame pane-name &key (errorp t)) + (let* ((descriptor (find-frame-descriptor frame)) + (position (if (typep pane-name 'window-mixin) + (position pane-name (frame-panes frame)) + (position pane-name (frame-descriptor-pane-descriptions descriptor) + :key #'pane-descriptor-name)))) + (when (and (null position) + (dummy-pane-p pane-name)) + (setq position (position pane-name (frame-panes frame)))) + (if (null position) + (when errorp + (error "There is no pane named ~S in frame ~S" pane-name frame)) + (let ((pane (elt (frame-panes frame) position)) + (descr (elt (frame-descriptor-pane-descriptions descriptor) position))) + ;; Note that this can return dummy panes! + (values pane descr))))) + +(defun title-capitalize (string) + (let ((new-string (substitute #\Space #\- string))) + (when (eq new-string string) + (setq new-string (copy-seq new-string))) + (nstring-capitalize new-string))) + +(defun display-title (frame stream) + (multiple-value-bind (pane desc) (get-frame-pane frame stream) + (when (and pane (eq pane stream)) + (let ((title (getf (pane-descriptor-options desc) :display-string))) + (when (and (stringp title) + (not (string-equal title (frame-pretty-name frame)))) + ;; On some hosts this will update the title bar + (setf (frame-pretty-name frame) title)) + (when (and (eq stream pane) (not (dummy-pane-p pane))) + (multiple-value-bind (width height) + (window-inside-size stream) + (draw-string* stream (or title (frame-pretty-name frame)) + (/ width 2) (/ height 2) + :align-x :center :align-y :center)) + (force-output stream)) + (values))))) + +(defun display-command-menu (frame stream &rest keys + &key command-table &allow-other-keys) + (declare (dynamic-extent keys)) + (declare (arglist frame stream &rest keys + &key command-table + ;; Defaults for these provided by DISPLAY-COMMAND-TABLE-MENU + max-width max-height n-rows n-columns + (cell-align-x ':left) (cell-align-y ':top) + (initial-spacing t))) + ;;--- This really wants to get the information from some other place + ;;--- than having to find the descriptor each time, which is kludgy at best. + (multiple-value-bind (descriptor pane) + (do ((panes (frame-panes frame) (cdr panes)) + (descriptions (frame-descriptor-pane-descriptions + (find-frame-descriptor frame)) + (cdr descriptions))) + ((null panes) nil) + (when (eq (first panes) stream) + (return (values (first descriptions) (first panes))))) + (when pane + (let ((command-table + (find-command-table (or command-table (frame-command-table frame)))) + (incremental-redisplay + (getf (pane-descriptor-options descriptor) :incremental-redisplay)) + (*application-frame* frame)) + (with-keywords-removed (keys keys '(:command-table)) + (if incremental-redisplay + (apply #'display-command-menu-1 stream command-table keys) + (apply #'display-command-table-menu command-table stream keys))))))) + +;; Split out to avoid consing unnecessary closure environments. +(defun display-command-menu-1 (stream command-table &rest keys) + (declare (dynamic-extent keys)) + (updating-output (stream :unique-id stream + :cache-value (slot-value command-table 'menu-tick)) + (apply #'display-command-table-menu command-table stream keys))) + +(defmethod run-frame-top-level :around ((frame standard-application-frame)) + (with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame)) + (with-slots (top-level-sheet) frame + (unwind-protect + (let ((*frame-layout-changing-p* *frame-layout-changing-p*) + ;; Reset the state of the input editor and the presentation + ;; type system, etc., in case there is an entry into another + ;; application from inside the input editor, such as a Debugger + ;; written using CLIM. + ;;--- This should be done in a more modular way + ;;--- If you change this, change MENU-CHOOSE-FROM-DRAWER + (*original-stream* nil) + (*input-wait-test* nil) + (*input-wait-handler* nil) + (*pointer-button-press-handler* nil) + (*generate-button-release-events* nil) + (*numeric-argument* nil) + (*blip-gestures* nil) + (*activation-gestures* nil) + (*accelerator-gestures* nil) + (*input-context* nil) + (*accept-help* nil) + (*assume-all-commands-enabled* nil) + (*sizing-application-frame* nil) + (*command-parser* 'command-line-command-parser) + (*command-unparser* 'command-line-command-unparser) + (*partial-command-parser* + 'command-line-read-remaining-arguments-for-partial-command)) + (loop + (with-simple-restart (nil "~A top level" (frame-pretty-name frame)) + (when top-level-sheet + (window-expose top-level-sheet)) + (loop + (catch 'resynchronize + (let ((*application-frame* frame) + (*pointer-documentation-output* + (frame-pointer-documentation-output frame))) + ;; We must return the values from CALL-NEXT-METHOD, + ;; or else ACCEPTING-VALUES will return NIL + #-CCL-2 + (return-from run-frame-top-level (call-next-method)) + ;; The (RETURN-FROM FOO (CALL-NEXT-METHOD)) form above + ;; doesn't work in Coral. If the "top level" restart + ;; above is taken, the CALL-NEXT-METHOD form blows out + ;; the second time through this code, claiming that it + ;; can't find the next method. Hoisting the + ;; CALL-NEXT-METHOD out of the RETURN-FROM form seems + ;; to fix it... So it conses, big deal. + #+CCL-2 + (let ((results (multiple-value-list (call-next-method)))) + (return-from run-frame-top-level (values-list results))))))))) + (when top-level-sheet + (setf (window-visibility top-level-sheet) nil)))))) + +(defmethod run-frame-top-level ((frame standard-application-frame)) + (let* ((descriptor (find-frame-descriptor frame)) + (top-level (frame-descriptor-top-level descriptor))) + (apply (first top-level) frame (rest top-level)))) + +(defun find-pane-of-type (frame type &key (if-current t)) + (let ((current-panes (frame-current-panes frame))) + (do ((panes (frame-panes frame) (cdr panes)) + (descriptions (frame-descriptor-pane-descriptions (find-frame-descriptor frame)) + (cdr descriptions))) + ((null panes) nil) + (let* ((pane (first panes)) + (descriptor (first descriptions))) + (when (and (eq (pane-descriptor-type descriptor) type) + (or (null if-current) + (member pane current-panes))) + (return (values pane descriptor))))))) + +(defmethod frame-standard-output ((frame standard-application-frame)) + (or (find-pane-of-type frame ':application) + (find-pane-of-type frame ':interactor))) + +(defmethod frame-standard-input ((frame standard-application-frame)) + (or (find-pane-of-type frame ':interactor) + (frame-standard-output frame))) + +(defmethod frame-query-io ((frame standard-application-frame)) + (or (frame-standard-input frame) + (frame-standard-output frame))) + +(defmethod frame-error-output ((frame standard-application-frame)) + (frame-standard-output frame)) + +(defmethod frame-pointer-documentation-output ((frame standard-application-frame)) + ;; If it's a Genera frame, use the mouse-doc line, otherwise find + ;; the pointer documentation pane. + (or #+Genera (let ((stream (frame-top-level-sheet frame))) + (and (typep stream 'sheet-window-stream) + (not (null (tv:screen-who-line-screen + (tv:sheet-screen (slot-value stream 'window))))))) + (find-pane-of-type frame ':pointer-documentation))) + +(defmethod read-frame-command ((frame standard-application-frame) + &key (stream *query-io*) ;frame-query-io? + ;; should the rest of the *command-parser* + ;; etc. variables be passed as keywords or bound? + ) + (read-command (frame-command-table frame) :stream stream)) + +(defmethod execute-frame-command ((frame standard-application-frame) command) + (apply (command-name command) (command-arguments command))) + +;;--- This causes direct-manipulation and menu-driven applications not to +;;--- maintain histories. Is there a better heuristic? +(defmethod frame-maintain-presentation-histories ((frame standard-application-frame)) + (not (null (find-pane-of-type frame ':interactor :if-current nil)))) + +;; Generic because someone might want :BEFORE or :AFTER +(defmethod frame-exit ((frame standard-application-frame)) + (invoke-restart 'frame-exit)) + +(defmethod notify-user ((frame standard-application-frame) format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply #'notify-user-1 (frame-top-level-sheet frame) frame format-string format-args)) + +(defun default-frame-top-level (frame + &key command-parser command-unparser partial-command-parser + (prompt "Command: ")) + (let* ((*standard-output* + (or (frame-standard-output frame) *standard-output*)) + (*standard-input* + (or (frame-standard-input frame) *standard-output*)) + (*query-io* + (or (frame-query-io frame) *standard-input*)) + (*error-output* + (or (frame-error-output frame) *standard-output*)) + (interactor (not (null (find-pane-of-type frame ':interactor)))) + (*command-parser* + (or command-parser + (if interactor + #'command-line-command-parser + #'menu-command-parser))) + (*command-unparser* + (or command-unparser + #'command-line-command-unparser)) + (*partial-command-parser* + (or partial-command-parser + (if interactor + #'command-line-read-remaining-arguments-for-partial-command + #'menu-read-remaining-arguments-for-partial-command)))) + + ;; The read-eval-print loop for applications... + (loop + ;; Redisplay all the panes + (redisplay-frame-panes frame) + (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name 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*))) + (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 standard-application-frame) &key force-p) + (with-slots (panes pane-descriptions current-panes) frame + (do ((windows panes (cdr windows)) + (descriptions pane-descriptions (cdr descriptions))) + ((null windows) nil) + (let* ((window (first windows)) + (description (first descriptions))) + (when (member window current-panes) + (redisplay-frame-pane-1 frame window description force-p)))) + (setq *frame-layout-changing-p* nil))) + +(defmethod redisplay-frame-pane ((frame standard-application-frame) pane-name &key force-p) + (multiple-value-bind (pane description) + (get-frame-pane frame pane-name) + (redisplay-frame-pane-1 frame pane description force-p))) + +;; FORCE-P can be NIL (meaning just do the redisplay normally) or T (meaning +;; forcibly redisplay the pane). +(defun redisplay-frame-pane-1 (frame pane description &optional force-p) + (let* ((options (pane-descriptor-options description)) + (display-function (getf options :display-function)) + (incremental-redisplay (getf options :incremental-redisplay)) + (redisplay-record + (and incremental-redisplay + (let ((history (stream-output-history pane))) + (when history + #+compulsive-redisplay + (when (> (output-record-count history) 1) + (cerror "Clear the output history and proceed" + "There more than one output record in this redisplay pane") + (window-clear pane)) + (unless (zerop (output-record-count history)) + (output-record-element history 0))))))) + ;; We're trying to get bits on the screen. + (cond ((dummy-pane-p pane) + ;; Give everyone a chance to update the title bar + (when (eql (pane-descriptor-type description) :title) + (display-title frame pane))) + (t + (when *frame-layout-changing-p* + (setq force-p t)) + (unless *sizing-application-frame* + (unless (member pane (slot-value frame 'initialized-panes)) + (setq force-p t) + (push pane (slot-value frame 'initialized-panes)))) + (with-simple-restart (nil "Skip redisplaying pane ~S" pane) + (loop + (with-simple-restart (nil "Retry displaying pane ~S" pane) + (return + (cond (display-function + ;; If there's a display function, call it to generate new contents. + (cond (incremental-redisplay + (cond ((or (null redisplay-record) force-p) + (when force-p + (window-clear pane)) + (call-redisplay-function + display-function frame pane)) + (t (redisplay redisplay-record pane)))) + ((or force-p + (getf options :display-after-commands t)) + (unless (and (not force-p) + (eq (getf options :display-after-commands) + ':no-clear)) + (window-clear pane)) + (call-display-function display-function frame pane))) + (force-output pane)) + (force-p + ;; If refilling from scratch, give the application a chance + ;; to draw stuff + (frame-replay frame pane)) + ;; Otherwise do nothing, the bits will still be on display + ;; and will be refreshed properly if there's a damage event. + ))))))))) + +;; Factored out of the above to avoid consing closures +(defun call-redisplay-function (display-function frame pane &rest args) + (declare (dynamic-extent args)) + (updating-output (pane) + (apply #'call-display-function display-function frame pane args))) + +(defun call-display-function (display-function frame pane &rest args) + (declare (dynamic-extent args)) + (let* ((display-args + (if (listp display-function) (rest display-function) nil)) + (display-function + (if (listp display-function) (first display-function) display-function))) + ;; Cons as little as possible... + (cond ((and (null args) (null display-args)) + (funcall display-function frame pane)) + ((null display-args) + (apply display-function frame pane args)) + ((null args) + (apply display-function frame pane display-args)) + (t + (apply display-function frame pane (nconc (copy-list args) display-args)))))) + + +;;; Enabling and disabling of commands + +(defmethod command-enabled (command-name (frame standard-application-frame)) + (with-slots (disabled-commands) frame + (or *assume-all-commands-enabled* + (and (not (member command-name disabled-commands)) + (command-accessible-in-command-table-p + command-name (frame-command-table frame)))))) + +(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame)) + (with-slots (disabled-commands) frame + (if enabled + (setf disabled-commands (delete command-name disabled-commands)) + (push command-name disabled-commands)))) + +#+CLIM-1-compatibility +(progn +(define-compatibility-function (command-enabled-p command-enabled) + (command-name frame) + (command-enabled command-name frame)) + +(define-compatibility-function (enable-command (setf command-enabled)) + (command-name frame) + (setf (command-enabled command-name frame) t)) + +(define-compatibility-function (disable-command (setf command-enabled)) + (setf (command-enabled command-name frame) nil)) +) ;#+CLIM-1-compatibility diff --git a/pre-silica/defs-graphics-generics.lisp b/pre-silica/defs-graphics-generics.lisp new file mode 100644 index 00000000..546c756b --- /dev/null +++ b/pre-silica/defs-graphics-generics.lisp @@ -0,0 +1,504 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: defs-graphics-generics.lisp,v 1.4 91/03/26 12:47:54 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +(eval-when (compile load eval) + +;; NOTE: if you change this list of keywords, you also have to change the keyword arguments +;; accepted by (CLOS:METHOD INVOKE-WITH-DRAWING-OPTIONS (DRAWING-STATE-MIXIN T)) +(defparameter *all-drawing-options* + '(:ink :clipping-region :transformation + :line-style :line-unit :line-thickness :line-dashes + :line-joint-shape :line-cap-shape + :text-style :text-family :text-face :text-size)) + +(defparameter *always-meaningful-drawing-options* '(:ink :clipping-region :transformation)) + +(defparameter *drawing-option-subsets* + '((:point :line-style :line-thickness :line-unit) + (:line-cap :line-style :line-thickness :line-unit + :line-dashes :line-cap-shape) + (:line-joint :line-style :line-thickness :line-unit + :line-dashes :line-joint-shape) + (:line-joint-cap :line-style :line-thickness :line-unit + :line-dashes :line-joint-shape :line-cap-shape) + (:text :text-style :text-family :text-face :text-size))) + +(defun non-drawing-option-keywords (arglist) + (do ((l (cdr (member '&key arglist)) (cdr l)) + (non-drawing-option-keywords nil) + k) + ((null l) non-drawing-option-keywords) + (setq k (cond ((atom (car l)) (intern (string (car l)) "KEYWORD")) + ((atom (caar l)) (intern (string (caar l)) "KEYWORD")) + (t (caaar l)))) + (unless (member k *all-drawing-options*) + (push k non-drawing-option-keywords)))) + +;;; Caller must stick &key in front +;;; If drawing-options isn't nil, it's a list of the option keywords accepted. +(defun all-drawing-options-lambda-list (drawing-options) + (mapcar #'(lambda (keyword) (intern (string keyword))) + (cond ((null drawing-options) *all-drawing-options*) + ((atom drawing-options) + (append (or (cdr (assoc drawing-options *drawing-option-subsets*)) + (warn "~S was specified in :drawing-options but is not ~ + a known drawing-option subset." + drawing-options)) + *always-meaningful-drawing-options*)) + (t + (dolist (option drawing-options) + (unless (member option *all-drawing-options*) + (warn "~S was specified in :drawing-options but ~ + is not a known drawing option." + option))) + (append drawing-options *always-meaningful-drawing-options*))))) + +) ;eval-when + +(defclass graphics-mixin (drawing-state-mixin) ()) + +;;; Register this class. +(define-stream-protocol graphics-mixin) + +(define-protocol-p-method graphics-stream-p graphics-mixin) + +(defmacro define-graphics-operation (name arglist &key arguments method-body drawing-options) + (let ((method-name (fintern "~A-~A" name 'method))) + (with-warnings-for-definition name define-graphics-operation + `(define-group ,name define-graphics-operation + (defoperation ,method-name graphics-mixin + ((graphics-mixin graphics-mixin) + ,@(remove '&key (flatten-arglist arglist)))) + ,(define-graphics-method name method-name arglist arguments method-body) + ,(define-standard-graphics-operation-1 name method-name arglist + arguments drawing-options) + ,(define-point-graphics-operation-1 name method-name arglist + arguments drawing-options) + ,(define-point-sequence-operation-1 name method-name arglist + arguments drawing-options))))) + +(defmacro fix-points (&rest numbers) + `(progn ,@(do* ((numbers numbers (cdr numbers)) + (number (first numbers) (first numbers)) + (forms nil)) + ((null numbers) (nreverse forms)) + (push `(unless (integerp ,number) + (setf ,number (floor ,number))) + forms)) + (values))) + +(defmacro transform-points ((transform) &rest points) + (assert (evenp (length points)) () + "Points must be x/y pairs. There are an odd number of elements in ~S" + points) + (let ((xform '#:transform)) + `(let ((,xform ,transform)) + ,@(do* ((points points (cddr points)) + (x (first points) (first points)) + (y (second points) (second points)) + (forms nil)) + ((null points) (nreverse forms)) + (push `(multiple-value-setq (,x ,y) + (transform-point* ,xform ,x ,y)) + forms)) + (values)))) + +;;; Update the points list in the reference. +(defmacro transform-point-sequence (transform points-reference) + (let ((pts-sequence '#:points-sequence) + (pts-temp '#:points) + (original-pts-temp '#:original-points) + (xform '#:transform)) + ;;--- is a run-time error check worth it? + `(let ((,pts-sequence ,points-reference) + (,xform ,transform)) + (assert (evenp (length ,pts-sequence)) () + "Points must be x/y pairs. There are an odd number of elements in ~S" + ,pts-sequence) + (setf ,points-reference + (let* ((,pts-temp (copy-list ,pts-sequence)) + (,original-pts-temp ,pts-temp)) + (dorest (pt ,pts-sequence cddr) + (let ((x (first pt)) + (y (second pt))) + (multiple-value-bind (nx ny) + (transform-point* ,xform x y) + (setf (car ,pts-temp) nx + ,pts-temp (cdr ,pts-temp) + (car ,pts-temp) ny + ,pts-temp (cdr ,pts-temp))))) + ,original-pts-temp)) + (values)))) + +(defmacro transform-distances ((transform) &rest distances) + (assert (evenp (length distances)) () + "Distances must be dx/dy pairs. There are an odd number of elements in ~S" + distances) + (let ((xform '#:transform)) + `(let ((,xform ,transform)) + ,@(do* ((distances distances (cddr distances)) + (dx (first distances) (first distances)) + (dy (second distances) (second distances)) + (forms nil)) + ((null distances) (nreverse forms)) + (push `(multiple-value-setq (,dx ,dy) + (transform-distance ,xform ,dx ,dy)) + forms)) + (values)))) + + +;;; Macro to write all the version of a drawing function +;;; It also will write the drawing method in the simplest case. + +(defun define-graphics-method (drawing-function-name method-name arglist argument-specs method-body) + (declare (ignore drawing-function-name)) + (let ((method-arglist `((stream graphics-mixin) ,@(remove '&key (flatten-arglist arglist))))) + ;; This writes the draw-foo-method. By default, it will write a + ;; simple method body that transforms the args and calls the + ;; DRAW-FOO-INTERNAL method. The caller can supply a method body, + ;; and that body had better wrap WITH-TRANSFORMED-ARGUMENTS around + ;; its call to DRAW-FOO-INTERNAL methods, if any. + `(defmethod ,method-name ,method-arglist + ;; Write a "customized" macro that knows how to transform the + ;; args for this drawing function. The :method-body writer has + ;; to wrap this around any call to a DRAW-FOO-INTERNAL method. + (macrolet ((with-transformed-arguments (&body body) + ;; Postpone drawing-state update until last minute + `(progn + ;; Transform the positions, ltrbs, position + ;; sequences, and distances. + ,@(write-transform-clauses ',argument-specs + '(medium-transformation stream)) + ,@body))) + (progn + ,(or method-body + (error ":METHOD-BODY must be supplied."))))))) + +;;; Interprets the argument specs provided via the :arguments keyword to +;;; define-graphics-operation and writes the appropriate coordinate +;;; transform form. +(defun write-transform-clauses (argument-specs transform) + (let ((clauses nil)) + (dolist (spec argument-specs) + (case (first spec) + (point + ;; The rest of the spec is a list of x/y pairs + (assert (evenp (length (rest spec))) () + "Points must be listed in x/y pairs. ~S has an odd number of elements." + (rest spec)) + (push `(transform-points (,transform) ,@(rest spec)) + clauses)) + (rectangle + ;; The rest of the spec if a list of left/top/right/bottom 4-tuples. + (assert (zerop (mod (length (rest spec)) 4)) () + "Rectangles must have four values, left top right bottom. ~S" + (rest spec)) + (push `(transform-points (,transform) ,@(rest spec)) + clauses)) + (point-sequence + ;; Elements of REST are references containing lists of points. + (dolist (ps (rest spec)) + ;; No compile-time ASSERTion. + (push `(transform-point-sequence ,transform ,ps) + clauses))) + (distance + ;; The rest of the spec is a list of dx/dy pairs indicating a distance + (assert (evenp (length (rest spec))) () + "Distances must be listed in dx/dy pairs. ~S has an odd number of elements." + (rest spec)) + (push `(transform-distances (,transform) ,@(rest spec)) + clauses)))) + (nreverse clauses))) + +;;; Macro to write the DRAW-FOO-INTERNAL methods + +(defmacro adjust-for-viewport-and-margins (stream &rest points) + (assert (evenp (length points)) () + "Points must be x/y pairs. There are an odd number of elements in ~S" + points) + (let ((dx '#:dx) + (dy '#:dy)) + `(multiple-value-bind (,dx ,dy) + (drawing-surface-to-viewport-coordinates ,stream 0 0) + (translate-positions ,dx ,dy ,@points)))) + +(defmacro with-stipple-offsets ((sx sy array stream) &body body) + (let ((vx '#:viewport-x) + (vy '#:viewport-y) + (sw '#:stipple-width) + (sh '#:stipple-height)) + `(let ((,sx 0) + (,sy 0)) + (when ,array + (multiple-value-bind (,vx ,vy) + (window-viewport-position* ,stream) + (multiple-value-bind (,sw ,sh) + (values-list (array-dimensions ,array)) + (translate-positions (mod ,vx ,sw) (mod ,vy ,sh) ,sx ,sy)))) + ,@body))) + +(defmacro define-graphics-internal (name arglist + &key points-to-convert point-sequence-to-convert + bounding-rectangle + highlighting-test highlighting-function + output-recording-hook) + (when (and point-sequence-to-convert + (null output-recording-hook)) + ;; Since we're using NTRANSLATE below, we must avoid bashing user lists + (setq output-recording-hook + `(setq ,point-sequence-to-convert (copy-list ,point-sequence-to-convert)))) + (let* ((pass-on-arglist (make-pass-on-arglist arglist)) + (flat-arglist (flatten-arglist arglist)) + (class-name (fintern "~A-~A" + (remove-word-from-string + "-internal" (remove-word-from-string "draw-" name)) + 'displayed-output-record)) + (constructor-name (fintern "~A-~A" 'make class-name))) + `(;; define-group ,name define-graphics-internal ;; POS Genera + progn + (defgeneric ,name (stream x-offset y-offset ,@flat-arglist)) + (defclass ,class-name + (output-record-element-mixin graphics-displayed-output-record) + ,(mapcar #'(lambda (arg) `(,arg :initarg ,arg)) flat-arglist)) + (define-constructor-using-prototype-instance + ,constructor-name ,class-name ,flat-arglist + ,@(mapcar #'(lambda (arg) `(,arg ',arg ,arg)) flat-arglist)) + ;; I'm too damned lazy to invent another protocol to hang this off of... + (defmethod ,name ((stream standard-encapsulating-stream) xoff yoff ,@arglist) + (,name (slot-value stream 'stream) xoff yoff ,@pass-on-arglist)) + (defmethod ,name :around ((stream output-and-window-protocol-intermediary) + x-offset y-offset ,@arglist) + (declare (type coordinate x-offset y-offset)) + (adjust-for-viewport-and-margins stream x-offset y-offset) + (call-next-method stream x-offset y-offset ,@pass-on-arglist)) + (defmethod replay-output-record ((record ,class-name) stream + &optional region (x-offset 0) (y-offset 0)) + ;; Ignore the region and let MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION + ;; take care of not calling REPLAY-OUTPUT-RECORD unnecessarily. Too expensive here. + (declare (ignore region)) + (declare (type coordinate x-offset y-offset)) + (with-slots (,@flat-arglist) record + (,name stream x-offset y-offset ,@flat-arglist))) + (defmethod ,name :around ((stream graphics-output-recording) x-offset y-offset + ,@arglist) + (declare (ignore x-offset y-offset)) + (when (stream-recording-p stream) + ,output-recording-hook + (multiple-value-bind (abs-x abs-y) + (point-position* + (stream-output-history-position stream)) + (declare (type coordinate abs-x abs-y)) + ;; Adjust the coordinates by the position of the current record + (let ((rec (,constructor-name ,@flat-arglist))) + (multiple-value-bind (lf tp rt bt) + (progn ,bounding-rectangle) + (declare (type coordinate lf tp rt bt)) + (bounding-rectangle-set-edges + rec + (- lf abs-x) (- tp abs-y) + (- rt abs-x) (- bt abs-y))) + (multiple-value-bind (cx cy) (stream-cursor-position* stream) + (declare (type coordinate cx cy)) + ;; Doing this directly beats calling OUTPUT-RECORD-SET-START-CURSOR-POSITION* + (with-slots (start-x start-y) rec + (setq start-x (- cx abs-x) + start-y (- cy abs-y))) + ;; Adjust the stored coordinates by the current cursor position + ,@(when points-to-convert + `((with-slots (,@points-to-convert) rec + (translate-positions (- abs-x) (- abs-y) ,@points-to-convert)))) + ,@(when point-sequence-to-convert + `((with-slots (,point-sequence-to-convert) rec + (setq ,point-sequence-to-convert + (ntranslate-point-sequence (- abs-x) (- abs-y) + ,point-sequence-to-convert)))))) + (stream-add-output-record stream rec)))) + (when (stream-drawing-p stream) + (call-next-method))) + + ,@(when highlighting-test + (let ((args (first highlighting-test)) + (body (rest highlighting-test))) + `((defmethod output-record-refined-sensitivity-test ((record ,class-name) ,@args) + ,@body)))) + ,@(when highlighting-function + (let ((args (first highlighting-function)) + (body (rest highlighting-function))) + `((defmethod highlight-output-record-1 ((record ,class-name) ,@args) + ,@body))))))) + + +;;; Macro helpers to write the user-called drawing functions. + +;;; First some helper functions. + +;;; Extract the positional and &rest arguments from an arglist. +(defun compute-pass-on (arglist) + (let ((pass-on nil)) + (dolist (arg arglist) + (cond ((eql arg '&key) + (return)) + (t (push arg pass-on)))) + (nreverse pass-on))) + +;;; Splice in an "&rest .args." before the &key in an arglist. +(defun add-&rest (arglist &optional (rest-arg-var '.args.)) + (let ((pos-&key (position '&key arglist))) + (append (subseq arglist 0 pos-&key) + `(&rest ,rest-arg-var) + (when pos-&key + (subseq arglist pos-&key))))) + +(defun apply-method-code (method-name stream pass-on args non-drawing-option-keywords) + `(if ,args + (flet ((trampoline () + (,method-name ,stream ,@pass-on))) + (declare (dynamic-extent #'trampoline)) + ,(if non-drawing-option-keywords + `(with-keywords-removed (drawing-options ,args ',non-drawing-option-keywords) + (apply #'invoke-with-drawing-options ,stream #'trampoline drawing-options)) + `(apply #'invoke-with-drawing-options ,stream #'trampoline ,args))) + (,method-name ,stream ,@pass-on))) + +;;; Writes the "standard" draw-foo* function, which takes separate X and Y arguments. +(defun define-standard-graphics-operation-1 (name method-name arglist + arguments drawing-options) + (declare (ignore arguments)) + (let ((pass-on (remove '&key (flatten-arglist arglist))) + (fcn-args (add-&rest (append arglist + (if (member '&key arglist) + `(&allow-other-keys) + `(&key &allow-other-keys))) + '.args.)) + ;; Spread form is called DRAW-FOO* + (function-name (fintern "~A*" name))) + `(progn + (defun ,function-name (stream ,@fcn-args) + (declare (dynamic-extent .args.)) + (declare (arglist stream + ,@arglist + ,@(unless (member '&key arglist) `(&key)) + ,@(all-drawing-options-lambda-list drawing-options))) + ,(apply-method-code method-name 'stream pass-on '.args. + (non-drawing-option-keywords arglist))) + ,(when (null (intersection arglist lambda-list-keywords)) + `(define-compiler-macro ,function-name (&whole form &rest args) + (when (= (length args) (1+ ,(length arglist))) + (return-from ,function-name + `(,',method-name ,@args))) + form))))) + +;;; Writes the draw-foo version, which spreads out the points into positions. +(defun define-point-graphics-operation-1 (name method-name arglist arguments drawing-options) + ;; Turn adjacent args of type point into "point" arguments + (let ((point-arglist nil) + (point-associations nil) + (count 1) + (point-args (cdr (assoc 'point arguments)))) + (when point-args + (do* ((args arglist (cdr args)) + (arg (first args) (first args))) + ((null args) nil) + (let ((stuff (member arg point-args))) + (cond ((and stuff + (eql (second args) (second stuff))) + (let ((point-varname + (fintern "~A-~D" 'point count))) + (incf count) + (push `(,(first args) ,(second args) ,point-varname) point-associations) + (push point-varname point-arglist)) + (setq args (cdr args))) + (t (push arg point-arglist))))) + (setq point-arglist + (append (reverse point-arglist) + (if (member '&key point-arglist) + `(&allow-other-keys) + `(&key &allow-other-keys)))) + (setq point-arglist (add-&rest point-arglist '.args.)) + ;; Structure-oriented version is called DRAW-FOO + (let ((function-name name)) + (flet ((let-args () + (let ((args nil)) + (dolist (spec point-associations) + (push (first spec) args) + (push (second spec) args)) + (nreverse args))) + (set-clauses () + (let ((clauses nil)) + (dolist (spec point-associations) + (push `(setf ,(first spec) (point-x ,(third spec))) clauses) + (push `(setf ,(second spec) (point-y ,(third spec))) clauses)) + (nreverse clauses)))) + `(defun ,function-name (stream ,@point-arglist) + (declare (dynamic-extent .args.)) + (declare (arglist stream + ,@(ldiff point-arglist (member '&rest point-arglist)) + &key ,@(cdr (member '&key arglist)) + ,@(all-drawing-options-lambda-list drawing-options))) + (let (,@(let-args)) + ,@(set-clauses) + ,(apply-method-code method-name 'stream (remove '&key (flatten-arglist arglist)) + '.args. (non-drawing-option-keywords arglist))))))))) + +;;; Writes the DRAW-FOO version for things that take an arg that is a +;;; sequence of points/positions. +(defun define-point-sequence-operation-1 (name method-name arglist arguments drawing-options) + ;; turn point-sequence (list of x&ys) args into sequences of points + ;; (inefficiently). + (let ((point-sequence-arglist nil) + (point-sequence-associations nil) + (count 1) + (point-sequence-args (cdr (assoc 'point-sequence arguments)))) + (when point-sequence-args + (do* ((args arglist (cdr args)) + (arg (first args) (first args))) + ((null args) nil) + (let ((stuff (member arg point-sequence-args))) + (cond (stuff + (let ((point-sequence-varname + (fintern "~A-~D" 'point-sequence count))) + (incf count) + (push `(,(first args) ,point-sequence-varname) point-sequence-associations) + (push point-sequence-varname point-sequence-arglist))) + (t (push arg point-sequence-arglist))))) + (setq point-sequence-arglist + (append (reverse point-sequence-arglist) + (if (member '&key point-sequence-arglist) + `(&allow-other-keys) + `(&key &allow-other-keys)))) + (setq point-sequence-arglist (add-&rest point-sequence-arglist '.args.)) + ;; Structure-oriented version is called DRAW-FOO + (let ((function-name name)) + (flet ((let-args () + (let ((args nil)) + (dolist (spec point-sequence-associations) + (push (first spec) args)) + (nreverse args))) + (set-clauses () + (let ((clauses nil)) + (dolist (spec point-sequence-associations) + (push `(do* ((points ,(second spec) (cdr points)) + (point (first points) (first points))) + ((null points) (setq ,(first spec) (nreverse ,(first spec)))) + (push (point-x point) ,(first spec)) + (push (point-y point) ,(first spec))) + clauses)) + (nreverse clauses)))) + `(defun ,function-name (stream ,@point-sequence-arglist) + (declare (dynamic-extent .args.)) + (declare (arglist stream + ,@(ldiff point-sequence-arglist + (member '&rest point-sequence-arglist)) + &key ,@(cdr (member '&key arglist)) + ,@(all-drawing-options-lambda-list drawing-options))) + ,(ignore-arglist point-sequence-arglist) + (let (,@(let-args)) + ,@(set-clauses) + ,(apply-method-code method-name 'stream (remove '&key (flatten-arglist arglist)) + '.args. (non-drawing-option-keywords arglist))))))))) diff --git a/pre-silica/drawing-state-mixin.lisp b/pre-silica/drawing-state-mixin.lisp new file mode 100644 index 00000000..3a1fbc0c --- /dev/null +++ b/pre-silica/drawing-state-mixin.lisp @@ -0,0 +1,165 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: drawing-state-mixin.lisp,v 1.4 91/03/26 12:47:56 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; Line Style + +(define-protocol-class line-style ()) + +(defclass standard-line-style (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) + #+++ignore (initial-dash-phase :initform 0 :initarg :initial-dash-phase + :reader line-style-initial-dash-phase))) + +(defmethod print-object ((line-style standard-line-style) stream) + (print-unreadable-object (line-style stream :type t :identity t) + (with-slots (unit thickness joint-shape cap-shape dashes) line-style + (format stream "Units ~(~A~), thickness ~D, joint ~(~A~), cap ~(~A~), dashes ~S" + unit thickness joint-shape cap-shape dashes)))) + +(defvar +default-line-style+ (make-instance 'standard-line-style)) +(defvar +dashed-line-styles+ + (make-array 5 :initial-contents + (list (make-instance 'standard-line-style :thickness 0 :dashes t) + (make-instance 'standard-line-style :thickness 1 :dashes t) + (make-instance 'standard-line-style :thickness 2 :dashes t) + (make-instance 'standard-line-style :thickness 3 :dashes t) + (make-instance 'standard-line-style :thickness 4 :dashes t)))) +(defvar +undashed-line-styles+ + (make-array 5 :initial-contents + (list (make-instance 'standard-line-style :thickness 0 :dashes nil) + (make-instance 'standard-line-style :thickness 1 :dashes nil) + (make-instance 'standard-line-style :thickness 2 :dashes nil) + (make-instance 'standard-line-style :thickness 3 :dashes nil) + (make-instance 'standard-line-style :thickness 4 :dashes nil)))) + +(defun-inline make-line-style-1 (unit thickness dashes joint-shape cap-shape) + #+Genera (declare lt:(side-effects simple reducible)) + (if (and (eql unit :normal) + (eql joint-shape :miter) + (eql cap-shape :butt) + (integerp thickness) (<= 0 thickness 4) + (or (eq dashes t) (eq dashes nil))) + ;; Cache the common case when only :DASHES and :THICKNESS are provided + (svref (if dashes +dashed-line-styles+ +undashed-line-styles+) thickness) + (make-instance 'standard-line-style + :unit unit :thickness thickness :dashes dashes + :joint-shape joint-shape :cap-shape cap-shape))) + +(defun make-line-style (&key (unit :normal) (thickness 1) (dashes nil) + (joint-shape :miter) (cap-shape :butt)) + #+Genera (declare lt:(side-effects simple reducible)) + (make-line-style-1 unit thickness dashes joint-shape cap-shape)) + +(setq +highlighting-line-style+ (make-line-style :thickness 1)) + +(defmethod make-load-form ((line-style standard-line-style)) + (with-slots (unit thickness joint-shape cap-shape dashes) line-style + `(make-line-style ,@(unless (eq unit :points) `(:unit ,unit)) + ,@(unless (= thickness 1) `(:thickness ,thickness)) + ,@(unless (eq joint-shape :miter) `(:joint-shape ,joint-shape)) + ,@(unless (eq cap-shape :butt) `(:cap-shape ,cap-shape)) + ,@(unless (eq dashes nil) `(:dashes ,dashes))))) + + +(defclass drawing-state-mixin + () + ((ink :initform +foreground-ink+ :accessor medium-ink) + (transformation :initform +identity-transformation+ :accessor medium-transformation) + (transformed-clipping-region :initform +everywhere+) + (line-style :initform +default-line-style+ :accessor medium-line-style) + (+Y-upward-p :initform nil :accessor medium-+Y-upward-p))) + +(defmethod medium-clipping-region ((medium drawing-state-mixin)) + (with-slots (transformation transformed-clipping-region) medium + (untransform-region transformation transformed-clipping-region))) + +(defmethod (setf medium-clipping-region) (clipping-region (medium drawing-state-mixin)) + (with-slots (transformation transformed-clipping-region) medium + (setf transformed-clipping-region (transform-region transformation clipping-region))) + clipping-region) + +;; NOTE: if you change the keyword arguments accepted by this method, you +;; also have to change the list of keywords in *ALL-DRAWING-OPTIONS* +(defmethod invoke-with-drawing-options + ((medium drawing-state-mixin) 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 + (medium-line-style line-style)) medium + ;; Close the current output record if the drawing ink is changing + (unless (eq medium-ink ink) + (stream-close-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)) + (invoke-with-text-style medium #'call-continuation text-style 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))))) + +(defmethod invoke-with-drawing-options + ((stream standard-encapsulating-stream) continuation + &rest args &key &allow-other-keys) + (declare (dynamic-extent args)) + (apply #'invoke-with-drawing-options (slot-value stream 'stream) continuation args)) diff --git a/pre-silica/genera-implementation.lisp b/pre-silica/genera-implementation.lisp new file mode 100644 index 00000000..e65fe328 --- /dev/null +++ b/pre-silica/genera-implementation.lisp @@ -0,0 +1,1873 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: genera-implementation.lisp,v 1.4 91/03/26 12:48:48 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; Defined below +(eval-when (compile load eval) + (proclaim '(special *sheet-device*)) + #+IMach (proclaim '(special *small-sheet-device*))) + +(defconstant *alu-noop* boole-2) + +(defclass sheet-implementation-mixin + () + ((window :initarg :window) + (color-p :initform nil) + (embedded-p :initform nil) + (ink-cache :initform (make-ink-cache 16)))) + +;;; Will these SAGE variables be present in all Genera worlds? +;;; I don't want to have to figure out how many microns/pixel there are +;;; for each screen type. +(defmethod implementation-pixels-per-point ((stream sheet-implementation-mixin)) + (/ sage::*microns-per-point* sage:*microns-per-screen-pixel*)) + +(defmethod window-erase-viewport ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (when (window-drawing-possible stream) + (scl:send window :clear-window)))) + +(defmethod window-clear-area ((stream sheet-implementation-mixin) left top right bottom) + ;; In sheet window coordinates, basically + (with-slots (window) stream + (when (window-drawing-possible stream) + (scl:send window :draw-rectangle (- right left) (- bottom top) left top + (scl:send window :erase-aluf))))) + +(defmethod window-visibility ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (scl:send window :exposed-p))) + +(defmethod (setf window-visibility) (visibility (stream sheet-implementation-mixin)) + (with-slots (window) stream + ;; visibility is a boolean + (if visibility + ;; this isn't quite right, because activating it means it's now buried?? + (scl:send window :expose) + (scl:send window :deactivate)) + visibility)) + +(defmethod wait-for-window-exposed ((window sheet-implementation-mixin)) + (unless (window-visibility window) + (scl:process-wait "Await exposure" #'window-visibility window))) + +(defmethod window-drawing-possible ((stream sheet-implementation-mixin)) + (with-slots (window) stream + ;; tv:sheet-output-held-p, except that temp-locking only delays drawing, + ;; it doesn't make it impossible, so only look at the output-hold flag + (or (zerop (tv:sheet-output-hold-flag window)) + (tv:sheet-screen-array window)))) + +(defmethod window-stack-on-top ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (unless (scl:send window :exposed-p) + (scl:send window :expose)) + (let ((screen (tv:sheet-screen window)) + (console (tv:sheet-console window)) + (mouse (tv:sheet-mouse window))) + ;; SCREEN-MANAGE-AUTOEXPOSE-INFERIORS doesn't reliably select a window + ;; that fills the entire screen + (let ((sw (tv:console-selected-window console))) + (unless (and sw (atom (tv:sheet-lock sw))) + (scl:send window :select))) + (scl:send screen :screen-select) + (unless (eq screen (tv:sheet-screen (tv:mouse-sheet mouse))) + (tv:mouse-set-sheet screen))))) + +(defmethod window-stack-on-bottom ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (scl:send window :bury))) + +(defmethod close ((stream sheet-implementation-mixin) &key abort) + (declare (ignore abort)) + (with-slots (window) stream + (if (eq window (scl:send window :screen)) ; if this is a screen. + (mapc #'close (window-children stream)) + (scl:send window :kill)))) + +(defmethod bounding-rectangle-set-edges :after + ((stream sheet-implementation-mixin) left top right bottom) + (with-slots (window) stream + (let ((superior (tv:sheet-superior window))) + (when t ; (null (tv:sheet-superior superior)) ;root-p + (multiple-value-bind (wl wt wr wb) + (scl:send superior :inside-edges) + (declare (ignore wr wb)) + (translate-positions wl wt left top right bottom)))) + (scl:send window :set-edges left top right bottom))) + +(defmethod bounding-rectangle-set-position* :after + ((stream sheet-implementation-mixin) new-left new-top) + (with-slots (window) stream + (let ((superior (tv:sheet-superior window))) + (when t ; (null (tv:sheet-superior superior)) ;root-p + (multiple-value-bind (wl wt) + (scl:send superior :inside-edges) + (translate-positions wl wt new-left new-top)))) + (scl:send window :set-position new-left new-top))) + +(defmethod bounding-rectangle-set-size :after + ((stream sheet-implementation-mixin) width height) + (with-slots (window) stream + (multiple-value-bind (wl wt wr wb) + (scl:send window :inside-edges) + (setq wr (+ wl width) + wb (+ wt height)) + (scl:send window :set-edges wl wt wr wb)))) + +(defmethod stream-force-output ((stream sheet-implementation-mixin)) + ;; yikes!! Don't charge the screen-manager overhead to the caller! + #+Ignore + (with-slots (window) stream + (tv:screen-manage-window-area window))) + +(defmethod stream-clear-output ((stream sheet-implementation-mixin)) + ) + +(defmethod stream-finish-output ((stream sheet-implementation-mixin)) + ;; kludge after kludge + (stream-force-output stream)) + +(defmethod redisplay-decorations ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (when (window-drawing-possible stream) + (scl:send window :refresh-margins)))) + +(defmethod window-refresh ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (scl:send window :refresh))) + +(defun clim-label->genera-label (label-spec stream) + (when label-spec + (let (label label-text-style character-style) + (setq label (cond ((stringp label-spec) label-spec) + (t (first label-spec)))) + + (setq label-text-style + (cond ((stringp label-spec) + (stream-merged-text-style stream)) + ((getf (rest label-spec) :text-style)) + (t (stream-merged-text-style stream)))) + + (setq character-style + (si:intern-character-style :device-font + (tv:font-name + (text-style-mapping + (slot-value stream 'display-device-type) + *standard-character-set* + label-text-style + (slot-value stream 'window))) + :normal)) + `(:string ,label :character-style ,character-style)))) + +;;; A label is either a string or a list of the form (string :text-style style). +(defmethod (setf window-label) :after (new-label (stream sheet-implementation-mixin)) + (with-slots (window) stream + (multiple-value-bind (old-width old-height) + (scl:send window :inside-size) + (let ((genera-label (clim-label->genera-label new-label stream))) + (scl:send window :set-label genera-label)) + (ignore-errors + (scl:send window :set-inside-size old-width old-height))))) + +(defmethod window-label-size ((stream sheet-implementation-mixin) + &optional (label (window-label stream))) + (cond ((null label) + (values 0 0)) + (t (dw::margin-label-size (clim-label->genera-label label stream) + (slot-value stream 'window))))) + +(defmethod window-margins ((stream sheet-implementation-mixin)) + stream + (values 0 0 0 0)) + +(defmethod host-window-margins ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (scl:send window :margins))) + +(defmethod window-beep ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (scl:send window :beep))) + +(defmethod window-flush-update-region ((stream sheet-implementation-mixin)) + (with-slots (update-region) stream + (setf update-region nil))) + +(defmethod window-process-update-region ((stream sheet-implementation-mixin)) + (with-slots (update-region) stream + (when update-region + (multiple-value-bind (vx vy) + (window-viewport-position* stream) + (dolist (rectangle update-region) + (with-bounding-rectangle* (left top right bottom) rectangle + (translate-positions (- vx) (- vy) left top right bottom) + (window-clear-area stream left top right bottom))))))) + +(defmethod window-shift-visible-region :after ((stream sheet-implementation-mixin) + old-left old-top old-right old-bottom + new-left new-top new-right new-bottom) + (let ((rectangles (ltrb-difference new-left new-top new-right new-bottom + old-left old-top old-right old-bottom))) + (setf (slot-value stream 'update-region) rectangles))) + +;; Does this want to be an :after method? Will the primary method on +;; window-stream ever want to do anything else? +(defmethod stream-set-input-focus ((stream sheet-implementation-mixin)) + (with-slots (window) stream + (prog1 (sys:console-selected-window (tv:sheet-console window)) + ;; :select-relative ? + (scl:send window :select)))) + +(defmethod stream-restore-input-focus ((stream sheet-implementation-mixin) + old-focus) + (with-slots (window) stream + (unless (eq old-focus window) + (if (eq (scl:send old-focus :alias-for-selected-windows) + (scl:send window :alias-for-selected-windows)) + (scl:send old-focus :select-relative) + (scl:send window :deselect t))))) + +(defmethod copy-area ((stream sheet-implementation-mixin) + from-left from-top from-right from-bottom + to-left to-top) + (with-slots (window) stream + (when (window-drawing-possible stream) + (fix-points from-left from-top from-right from-bottom to-left to-top) + ;; coords in "host" coordinate system + (let ((width (- from-right from-left)) + (height (- from-bottom from-top))) + (when (>= to-left from-left) + ;; shifting to the right + (setq width (- (abs width)))) + (when (>= to-top from-top) + (setq height (- (abs height)))) + (scl:send window :bitblt-within-sheet + tv:alu-seta width height + from-left from-top + to-left to-top))))) + +(defmethod notify-user-1 ((stream sheet-implementation-mixin) + frame format-string &rest format-args) + (declare (ignore frame) (dynamic-extent format-args)) + (apply #'tv:notify (slot-value stream 'window) format-string format-args)) + + +;;;; Translation between CLIM and Genera graphics model + +;;; We cache the translation of the most recently used inks in a small array, +;;; using a property-list masquerade for quick lookup. When a cache element +;;; is replaced, any temporary resources used by the translation are returned +;;; (temporary rasters are currently the only examples). +(defun make-ink-cache (size) + (let ((array (make-array size :fill-pointer t))) + (setf (sys:%p-cdr-code (scl:locf (aref array (1- size)))) sys:cdr-nil) + (values array))) + +(defun-inline ink-cache-lookup (cache ink) + (getf (sys:%make-pointer sys:dtp-list (scl:locf (aref cache 0))) ink)) + +(defun ink-cache-replace (cache ink value) + (let ((index (fill-pointer cache))) + (when (<= (array-total-size cache) index) + (setq index 0)) + ;; Deallocate the previous temporary rasters + (let ((value (aref cache (1+ index)))) + (when (listp value) + (dolist (element value) + (when (sixth element) + (tv:deallocate-temporary-sheet-bit-raster (first element)))))) + (setf (aref cache index) ink) + (setf (aref cache (1+ index)) value) + (setf (fill-pointer cache) (+ index 2)) + value)) + +(defun-inline follow-indirect-ink (ink stream) + (cond ((eq ink +foreground-ink+) (medium-foreground stream)) + ((eq ink +background-ink+) (medium-background stream)) + (t ink))) + +(defmethod sheet-decode-color (ink stream &optional (stipple-p t)) + (declare (ignore stipple-p stream)) + (error "Expected ~S to be a color. This may be due to an implementation limitation." ink)) + +(defun sheet-decode-luminance (luminance stipple-p) + (macrolet ((stipple (height width patterns) + `(quote ((,(graphics::make-stipple height width patterns) + ,boole-set ,boole-clr))))) + (if (not stipple-p) + (if (< luminance 0.5) boole-set boole-clr) + (sys:selector luminance < + (0.05 boole-set) + (0.1 (stipple 8 16 #b(0111111111111111 + 1111110111111111 + 1111111111110111 + 1101111111111111 + 1111111101111111 + 1111111111111101 + 1111011111111111 + 1111111111011111))) + (0.2 (stipple 8 8 #b(01111111 + 11101111 + 11111101 + 10111111 + 11110111 + 11111110 + 11011111 + 11111011))) + (0.3 (stipple 4 4 #b(0111 1101 1011 1110))) + (0.4 (stipple 3 3 #b(011 101 110))) + (0.6 (stipple 2 2 #b(01 10))) + (0.7 (stipple 3 3 #b(100 010 001))) + (0.8 (stipple 4 4 #b(1000 0010 0100 0001))) + (0.9 (stipple 8 8 #b(10000000 + 00010000 + 00000010 + 01000000 + 00001000 + 00000001 + 00100000 + 00000100))) + (0.95 (stipple 8 16 #b(1000000000000000 + 0000001000000000 + 0000000000001000 + 0010000000000000 + 0000000010000000 + 0000000000000010 + 0000100000000000 + 0000000000100000))) + (otherwise boole-clr))))) + +(defmethod sheet-decode-color ((ink gray-color) stream &optional (stipple-p t)) + (with-slots (color-p window) stream + (let ((luminance (slot-value ink 'clim-utils::luminance)) + (invert-p (not (funcall (tv:sheet-screen window) :bow-mode)))) + (cond ((= luminance 0.0) (if invert-p boole-clr boole-set)) + ((= luminance 1.0) (if invert-p boole-set boole-clr)) + ((not color-p) + (sheet-decode-luminance (if invert-p (- 1.0 luminance) luminance) stipple-p)) + (t + (funcall (tv:sheet-screen window) :compute-rgb-alu boole-1 + luminance luminance luminance (not invert-p))))))) + +(defmethod sheet-decode-color ((ink color) stream &optional (stipple-p t)) + (with-slots (color-p window) stream + (multiple-value-bind (r g b) + (color-rgb ink) + (let ((invert-p (not (funcall (tv:sheet-screen window) :bow-mode)))) + (if (not color-p) + (let ((luminance (color-luminosity r g b))) + (sheet-decode-luminance (if invert-p (- 1.0 luminance) luminance) stipple-p)) + (funcall (tv:sheet-screen window) :compute-rgb-alu boole-1 + r g b (not invert-p))))))) + +(defmethod sheet-decode-color ((ink flipping-ink) stream &optional (stipple-p t)) + (declare (ignore stipple-p)) + (with-slots (color-p window) stream + (if (not color-p) + (values boole-xor) + (multiple-value-bind (design1 design2) + (decode-flipping-ink ink) + (let ((ink1 (follow-indirect-ink design1 stream)) + (ink2 (follow-indirect-ink design2 stream))) + ;; Genera substrate can get confused about this... + (if (or (and (eq ink1 +black+) (eq ink2 +white+)) + (and (eq ink1 +white+) (eq ink2 +black+))) + (values boole-xor) + (values + (funcall (tv:sheet-screen window) :exchange-two-colors-aluf + (sheet-decode-color (follow-indirect-ink design1 stream) stream) + (sheet-decode-color (follow-indirect-ink design2 stream) stream))))))))) + +(defmethod sheet-decode-color ((ink standard-opacity) stream &optional (stipple-p t)) + (declare (ignore stream stipple-p)) + (if (> (slot-value ink 'clim-utils::value) 0.5) boole-1 boole-2)) + +(defun sheet-decode-raster (raster &optional width height key tiled-p) + (multiple-value-bind (swidth sheight) + (sys:decode-raster-array raster) + (let ((dwidth (if tiled-p (lcm width 32) (* (ceiling (1- width) 32) 32)))) + (if (and (= swidth dwidth) + (= (sys:array-type-field raster) sys:art-1b)) + (values raster) + (let ((source raster) + (destination (tv:make-temporary-sheet-bit-raster #*1010 dwidth height))) + (declare (sys:array-register-1d source destination)) + ;; If the tiling is going to leave gaps, we need to zero the destination first + (when (or (/= width swidth) (/= height sheight)) + (si:fill-array destination nil 0)) + (do ((i 0 (1+ i)) + (si 0 (+ si swidth)) + (di 0 (+ di dwidth))) + ((= i (min height sheight))) + (do ((offset 0 (+ offset width))) + ((>= offset dwidth)) + (let* ((s si) + (d (+ di offset)) + (w (min (- dwidth offset) swidth))) + (cond ((null key) + (sys:copy-array-portion source s (+ s w) + destination d (+ d w))) + ((integerp key) + (dotimes (ii w) + (declare (ignore ii)) + (setf (aref destination d) (if (= (aref source s) key) 1 0)) + (incf s) + (incf d))))))) + (values destination)))))) + +(defmethod sheet-decode-pattern ((ink pattern) stream &optional width height tiled-p) + (multiple-value-bind (array designs) + (decode-pattern ink) + (let ((width (or width (array-dimension array 1))) + (height (or height (array-dimension array 0)))) + (if (= (length designs) 2) + (let ((raster (sheet-decode-raster array width height nil tiled-p))) + (list + (list raster + (sheet-decode-color + (follow-indirect-ink (aref designs 1) stream) stream nil) + (sheet-decode-color + (follow-indirect-ink (aref designs 0) stream) stream nil) + (and (not tiled-p) width) + (and (not tiled-p) height) + (not (eq raster array))))) + (do* ((result (make-list (length designs))) + (i 0 (1+ i)) + (l result (cdr l))) + ((null l) result) + (setf (car l) (list (sheet-decode-raster array width height i tiled-p) + (sheet-decode-color + (follow-indirect-ink (aref designs i) stream) stream nil) + (if (zerop i) boole-clr boole-2) + (and (not tiled-p) width) + (and (not tiled-p) height) + t))))))) + +(defmethod sheet-decode-pattern ((ink design) stream &optional width height tiled-p) + (declare (ignore stream width height tiled-p)) + (error "Arbitrary patterned designs are not supported in this CLIM implementation")) + +(defmethod sheet-decode-pattern ((ink color) stream &optional width height tiled-p) + (declare (ignore stream width height tiled-p)) + (error "A pattern must be a bounded design, ~S isn't" ink)) + +(defmethod sheet-decode-ink ((ink color) stream) + (sheet-decode-color ink stream)) + +(defmethod sheet-decode-ink ((ink flipping-ink) stream) + (sheet-decode-color ink stream)) + +(defmethod sheet-decode-ink ((ink contrasting-ink) stream) + (if (slot-value stream 'color-p) + (sheet-decode-color (make-color-for-contrasting-ink ink) stream) + ;; More efficient than (SHEET-DECODE-COLOR (MAKE-GRAY-COLOR-FOR-CONTRASTING-INK INK)) + (let ((luminance (with-slots (clim-utils::which-one clim-utils::how-many) ink + (/ clim-utils::which-one clim-utils::how-many))) + (invert-p (not (funcall (tv:sheet-screen (slot-value stream 'window)) :bow-mode)))) + (cond ((= luminance 0.0) (if invert-p boole-clr boole-set)) + ((= luminance 1.0) (if invert-p boole-set boole-clr)) + (t + (sheet-decode-luminance (if invert-p (- 1.0 luminance) luminance) t)))))) + +(defmethod sheet-decode-ink ((ink pattern) stream) + (sheet-decode-pattern ink stream)) + +(defmethod sheet-decode-ink ((ink rectangular-tile) stream) + (multiple-value-bind (pattern width height) + (decode-rectangular-tile ink) + (sheet-decode-pattern pattern stream width height t))) + +(defmethod sheet-decode-ink ((ink stencil) stream) + (declare (ignore stream)) + (error "Stencils and opacities are not supported in this CLIM implementation")) + +(defmethod sheet-decode-ink ((ink composite-in) stream) + (declare (ignore stream)) + (error "Compositing is not supported in this CLIM implementation")) + +(defmethod sheet-decode-ink ((ink composite-out) stream) + (declare (ignore stream)) + (error "Compositing is not supported in this CLIM implementation")) + +(flavor:defgeneric with-clim-drawing-state (drawing-state ones-alu zeros-alu + thickness dashes line-style pattern + continuation &rest arguments) + (:inline-methods :recursive) + (:optimize speed)) + +(flavor:defmethod (with-clim-drawing-state graphics::raster-drawing-state :before) + (ones-alu zeros-alu thickness dashes line-style pattern + continuation &rest arguments) + (declare (ignore thickness dashes line-style continuation arguments)) + (setq graphics::source-pattern pattern) + (setq graphics::ones-alu ones-alu) + (setq graphics::zeros-alu zeros-alu)) + +(flavor:defmethod (with-clim-drawing-state graphics::drawing-state) + (ones-alu zeros-alu thickness dashes line-style pattern + continuation &rest arguments) + (declare (ignore zeros-alu)) + (setq graphics::alu ones-alu) + (setq graphics::thickness thickness) + (setq graphics::scale-thickness nil) + (when (not (null line-style)) + (setq graphics::dashed (not (null dashes))) + (setq graphics::dash-pattern dashes) + (setq graphics::line-end-shape (line-style-cap-shape line-style)) + (setq graphics::line-joint-shape (line-style-joint-shape line-style))) + (setq graphics::stipple pattern) + (setq graphics::scan-conversion-flags + (dpb 1 graphics::%%scan-conversion-host-allowed + (dpb 1 graphics::%%scan-conversion-round-coordinates 0))) + #+IMach + ;; MacIvories are wierd + (when (sys:system-case (:macivory t) (otherwise nil)) + (setq graphics::color nil graphics::gray-level 1) + (when (not (null pattern)) + (if (let ((width (array-dimension pattern 1)) + (height (array-dimension pattern 0))) + (and (<= height 8) + (or (= width 32) (<= width 8)))) + (setq graphics::stipple pattern) + (setf graphics::scan-conversion-flags + (dpb 0 graphics::%%scan-conversion-host-allowed + (dpb 1 graphics::%%scan-conversion-round-coordinates 0)))))) + (setf (ldb graphics::%%drawing-state-new-parameters graphics::flags) 0) + (apply continuation arguments)) + +;;; The easy continuation is called for simple drawing operations without patterning +;;; or line style options unsupported by the old Genera window system operations. +(defmethod with-appropriate-drawing-state + ((stream sheet-implementation-mixin) ink line-style easy hard) + (let ((alu (with-slots (ink-cache) stream + (let ((ink (follow-indirect-ink ink stream))) + (or (ink-cache-lookup ink-cache ink) + (ink-cache-replace ink-cache ink (sheet-decode-ink ink stream))))))) + (multiple-value-bind (thickness dashes) + (if (null line-style) + (values 0 nil) + (values (or (line-style-thickness line-style) 0) + (let ((dashes (line-style-dashes line-style))) + (if (eq dashes t) #(10 10) dashes)))) + ;; There's no way to get the ALU canonicalization done in a whopper or wrapper + ;; without incurring extraordinary performance penalties, so... + (macrolet ((with-drawing-state-kludge (drawing-state ones-alu zeros-alu + thickness dashes line-style raster + continuation window) + `(multiple-value-bind (ones-alu zeros-alu) + (if (not (and (integerp ,ones-alu) (integerp ,zeros-alu))) + (values ,ones-alu ,zeros-alu) + ;; This is boolean magic to construct a new alu code which + ;; combines the effects of doing a DRAW-xx with ONES-ALU + ;; everywhere there is a 1 in the source and that of doing a + ;; DRAW-xx with ZEROS-ALU everywhere there is a 0 in the + ;; source. + (values (logior (logand ,ones-alu #b0101) + (scl:rot (logand ,zeros-alu #b0101) 1)) + ,zeros-alu)) + (with-clim-drawing-state ,drawing-state ones-alu zeros-alu + ,thickness ,dashes ,line-style ,raster + ,continuation ,window)))) + (labels ((kernel (window) + (declare (sys:downward-function)) + (if (listp alu) + (dolist (element alu) + (sys:destructuring-bind (raster ones-alu zeros-alu) element + (with-drawing-state-kludge (graphics::get-drawing-state window) + ones-alu zeros-alu + thickness dashes line-style raster + hard window))) + (if (and easy + (not (slot-value stream 'embedded-p)) + (null dashes) + (<= thickness 1)) + (funcall easy window alu) + (with-drawing-state-kludge (graphics::get-drawing-state window) + alu boole-2 + thickness dashes line-style nil + hard window))))) + (with-slots (window) stream + (let ((clipping-region (slot-value stream 'transformed-clipping-region))) + (if (eq clipping-region +everywhere+) + (kernel window) + (with-bounding-rectangle* (left top right bottom) clipping-region + (with-stack-list (cr (+ (tv:sheet-left-margin-size window) left) + (+ (tv:sheet-top-margin-size window) top) + (+ (tv:sheet-right-margin-size window) right) + (+ (tv:sheet-bottom-margin-size window) bottom)) + (scl:letf (((tv:sheet-clipping-region window) cr)) + (kernel window)))))))))))) + + +;;;; Drawing primitives + +(defmacro round-points (&rest numbers) + `(progn ,@(do* ((numbers numbers (cdr numbers)) + (number (first numbers) (first numbers)) + (forms nil)) + ((null numbers) (nreverse forms)) + (push `(unless (integerp ,number) + (setf ,number (round ,number))) + forms)) + (values))) + +(defmethod draw-point-internal ((stream sheet-implementation-mixin) x-offset y-offset + x y ink line-style) + (when (window-drawing-possible stream) + (round-points x y) + (translate-positions x-offset y-offset x y) + (with-appropriate-drawing-state stream ink line-style + #'(lambda (window alu) + (declare (sys:downward-function)) + (funcall window :draw-point x y alu)) + #'(lambda (window) + (declare (sys:downward-function)) + (funcall (flavor:generic graphics:draw-point) window x y))))) + +(defmethod draw-line-internal ((stream sheet-implementation-mixin) x-offset y-offset + start-x start-y end-x end-y ink line-style) + (when (window-drawing-possible stream) + (round-points start-x start-y end-x end-y) + (translate-positions x-offset y-offset start-x start-y end-x end-y) + (with-appropriate-drawing-state stream ink line-style + #'(lambda (window alu) + (declare (sys:downward-function)) + (funcall window :draw-line start-x start-y end-x end-y alu t)) + #'(lambda (window) + (declare (sys:downward-function)) + (funcall (flavor:generic graphics:draw-line) window start-x start-y end-x end-y))))) + +(defmethod draw-rectangle-internal ((stream sheet-implementation-mixin) x-offset y-offset + left top right bottom ink line-style) + (when (window-drawing-possible stream) + (round-points left top right bottom) + (translate-positions x-offset y-offset left top right bottom) + (if (and (null line-style) + (typep ink 'pattern)) + ;; Looks like this is DRAW-ICON* + (draw-icon-internal stream left top right bottom ink) + (with-appropriate-drawing-state stream ink line-style + #'(lambda (window alu) + (declare (sys:downward-function)) + (if (null line-style) + (let ((width (abs (- right left))) + (height (abs (- bottom top)))) + (funcall window :draw-rectangle width height left top alu)) + (scl:stack-let ((lines (vector right top left top + left top left bottom + left bottom right bottom + right bottom right top))) + (funcall window :draw-multiple-lines lines alu nil)))) + #'(lambda (window) + (declare (sys:downward-function)) + (funcall (flavor:generic graphics:draw-rectangle) window left top right bottom + :filled (null line-style))))))) + +;; Fall back to DRAW-IMAGE. INK will be a pattern. +;;--- We have to resort to this because Genera always tiles. Sigh. +(defmethod draw-icon-internal ((stream sheet-implementation-mixin) left top right bottom ink) + (with-slots (window ink-cache) stream + (let* ((width (- right left)) + (height (- bottom top)) + (alus (or (ink-cache-lookup ink-cache ink) + (ink-cache-replace ink-cache ink (sheet-decode-ink ink stream))))) + (assert (= (length alus) 1) () + "CLIM only supports bitmap icons under Genera sheets") + (dolist (alu alus) + (let ((image (pop alu))) + (graphics:draw-image image left top + :image-right width :image-bottom height + :stream window)))))) + +(defmethod draw-polygon-internal ((stream sheet-implementation-mixin) x-offset y-offset + points closed ink line-style) + (macrolet ((pop-x (p) + `(let ((x (pop ,p))) + (+ (if (integerp x) x (round x)) x-offset))) + (pop-y (p) + `(let ((y (pop ,p))) + (+ (if (integerp y) y (round y)) y-offset)))) + (when (window-drawing-possible stream) + (let ((npoints (length points))) + (with-appropriate-drawing-state stream ink line-style + #'(lambda (window alu) + (declare (sys:downward-function)) + (if (null line-style) + (case npoints + (6 (let* ((p points) + (x1 (pop-x p)) (y1 (pop-y p)) + (x2 (pop-x p)) (y2 (pop-y p)) + (x3 (pop-x p)) (y3 (pop-y p))) + (funcall window :draw-triangle x1 y1 x2 y2 x3 y3 alu))) + (8 (let* ((p points) + (x1 (pop-x p)) (y1 (pop-y p)) + (x2 (pop-x p)) (y2 (pop-y p)) + (x3 (pop-x p)) (y3 (pop-y p)) + (x4 (pop-x p)) (y4 (pop-y p))) + (funcall window :draw-triangle x1 y1 x2 y2 x3 y3 alu) + (funcall window :draw-triangle x3 y3 x4 y4 x1 y1 alu))) + (otherwise + (with-stack-array (translated-points npoints) + (do ((i 0) + (p points)) + ((null p)) + (setf (aref translated-points (shiftf i (1+ i))) (pop-x p)) + (setf (aref translated-points (shiftf i (1+ i))) (pop-y p))) + (graphics::triangulate-polygon + #'(lambda (x1 y1 x2 y2 x3 y3) + (funcall window :draw-triangle x1 y1 x2 y2 x3 y3 alu)) + translated-points)))) + (with-stack-array (lines (* (+ npoints (if closed 0 -2)) 2)) + (let* ((p points) + (i 0) + (initial-x (pop-x p)) + (initial-y (pop-y p)) + (x initial-x) + (y initial-y)) + (loop + (setf (aref lines (shiftf i (1+ i))) x) + (setf (aref lines (shiftf i (1+ i))) y) + (setf (aref lines (shiftf i (1+ i))) (setq x (pop-x p))) + (setf (aref lines (shiftf i (1+ i))) (setq y (pop-y p))) + (when (null p) + (when closed + (setf (aref lines (shiftf i (1+ i))) x) + (setf (aref lines (shiftf i (1+ i))) y) + (setf (aref lines (shiftf i (1+ i))) initial-x) + (setf (aref lines (shiftf i (1+ i))) initial-y)) + (return)))) + (funcall window :draw-multiple-lines lines alu nil)))) + #'(lambda (window) + (declare (sys:downward-function)) + (with-stack-array (translated-points npoints) + (do ((i 0) + (p points)) + ((null p)) + (setf (aref translated-points (shiftf i (1+ i))) (pop-x p)) + (setf (aref translated-points (shiftf i (1+ i))) (pop-y p))) + (if (null line-style) + (funcall (flavor:generic graphics:draw-polygon) window translated-points + :filled t) + (funcall (flavor:generic graphics:draw-lines) window translated-points + :closed closed))))))))) + +(defmethod draw-ellipse-internal ((stream sheet-implementation-mixin) x-offset y-offset + center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) + (when (window-drawing-possible stream) + (round-points center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy) + (translate-positions x-offset y-offset center-x center-y) + (when (and start-angle + (= start-angle 0.0) + (= end-angle 2pi)) + ;; GRAPHICS:DRAW-CIRCLE draws nothing when given single-precision 2PI + (setq end-angle graphics:2pi)) + (multiple-value-bind (pre-stretch-angle x-radius y-radius axis-rotate-angle) + (2x2-singular-value-decomposition radius-1-dx radius-2-dx + radius-1-dy radius-2-dy) + (declare (ignore pre-stretch-angle)) + (setq x-radius (abs x-radius) y-radius (abs y-radius)) + (if (and (= x-radius y-radius) (null start-angle)) + ;; It's a complete circle + (with-appropriate-drawing-state stream ink line-style + #'(lambda (window alu) + (declare (sys:downward-function)) + (if (null line-style) + (funcall window :draw-filled-in-circle center-x center-y x-radius alu) + (funcall window :draw-circle center-x center-y x-radius alu))) + #'(lambda (window) + (declare (sys:downward-function)) + (funcall (flavor:generic graphics:draw-ellipse) window + center-x center-y x-radius y-radius + :filled (null line-style)))) + ;; For general ellipse, let Genera do all the work + (with-appropriate-drawing-state stream ink line-style + nil + #'(lambda (window) + (declare (sys:downward-function)) + (graphics:saving-graphics-transform (window) + (graphics:graphics-translate center-x center-y :stream window) + (when (/= axis-rotate-angle 0) + (graphics:graphics-rotate axis-rotate-angle :stream window)) + (funcall (flavor:generic graphics:draw-ellipse) window + 0 0 x-radius y-radius + :start-angle (or start-angle 0) + :end-angle (or end-angle graphics:2pi) + :filled (null line-style))))))))) + +(defmethod draw-string-internal ((stream sheet-implementation-mixin) x-offset y-offset + string x y start end align-x align-y text-style ink) + (when (window-drawing-possible stream) + (round-points x y) + (translate-positions x-offset y-offset x y) + (unless end + (setq end (length string))) + ;; ---OK to use this in the Genera implementation + (sys:stack-let ((substring (make-string (- end start)))) + (replace substring string :start2 start :end2 end) + (let* ((font (text-style-mapping (slot-value stream 'display-device-type) + *standard-character-set* text-style + (slot-value stream 'window))) + (height (sys:font-char-height font)) + (descent (- height (sys:font-baseline font))) + (ascent (- height descent))) + (incf x (compute-text-x-adjustment + align-x stream string text-style start end)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + (with-stack-list (style :device-font (tv:font-name font) :normal) + (with-appropriate-drawing-state stream ink nil + #'(lambda (window alu) + (declare (sys:downward-function)) + (funcall window :draw-string substring x y (1+ x) y nil style alu)) + #'(lambda (window) + (declare (sys:downward-function)) + (funcall (flavor:generic graphics:draw-string) window + substring x y :character-style style)))))))) + +(defmethod draw-character-internal ((stream sheet-implementation-mixin) x-offset y-offset + character x y align-x align-y text-style ink) + (when (window-drawing-possible stream) + (round-points x y) + (translate-positions x-offset y-offset x y) + (let* ((font (text-style-mapping (slot-value stream 'display-device-type) + *standard-character-set* text-style + (slot-value stream 'window))) + (height (sys:font-char-height font)) + (descent (- height (sys:font-baseline font))) + (ascent (- height descent))) + (incf x (compute-text-x-adjustment + align-x stream character text-style)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + (with-appropriate-drawing-state stream ink nil + #'(lambda (window alu) + (declare (sys:downward-function)) + (funcall window :draw-glyph (char-code character) font x y alu)) + #'(lambda (window) + (declare (sys:downward-function)) + (funcall (flavor:generic graphics:draw-glyph) window + (char-code character) font x y)))))) + + +;;; 13 November 1989: Optimization to make stream-glyph-for-character faster in the case where +;;; we are calling it a lot, in stream-scan-string-for-writing. We make this function be a +;;; macro. + +;;; This algorithm is a paraphrase of the apparent contents of TV:%DRAW-STRING-CLIPPED-INTERNAL +(defmacro with-sheet-stream-glyph-for-character (&body body) + `(macrolet ((stream-glyph-for-character (stream character style &optional our-font) + `(with-slots (display-device-type) ,stream + (multiple-value-bind (character-set index) + (char-character-set-and-index ,character) + ;; For now we are asserting that each string passed to WRITE-STRING will + ;; have no style changes within it. This is what our-font is all + ;; about. + (let* ((font (or our-font (text-style-mapping + display-device-type character-set + ,style nil))) + (FIT (sys:font-indexing-table font)) + (LKT (sys:font-left-kern-table font)) + (CWT (sys:font-char-width-table font)) + (escapement-x (if (diacritic-char-p ,character) 0 + (if CWT (aref CWT index) + (sys:font-char-width font)))) + (escapement-y 0) + (origin-x (if LKT (aref LKT index) 0)) + (origin-y (sys:font-baseline font)) + (bb-x (if FIT (- (aref FIT (1+ index)) (aref FIT index)) + (sys:font-char-width font))) + (bb-y (sys:font-char-height font))) + (values index font escapement-x escapement-y origin-x origin-y + bb-x bb-y (not (or FIT LKT CWT)))))))) + ,@body)) + +(defmethod stream-glyph-for-character ((stream sheet-implementation-mixin) + character style &optional our-font) + (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y + fixed-width-font-p)) + (with-sheet-stream-glyph-for-character + (stream-glyph-for-character stream character style our-font))) + +(defmethod stream-scan-string-for-writing ((stream sheet-implementation-mixin) string + start end style cursor-x max-x + &optional glyph-buffer) + (with-sheet-stream-glyph-for-character + (stream-scan-string-for-writing-body))) + +(defmethod stream-write-char-1 ((stream sheet-implementation-mixin) index font color x y) + (let ((window (slot-value stream 'window))) + (when (window-drawing-possible stream) + (tv:prepare-sheet (window) + (let ((x (+ x (tv:sheet-left-margin-size window))) + (y (+ y (tv:sheet-top-margin-size window)))) + ;; There is apparently no way to draw a glyph exactly where you want + ;; it on a sheet! Draw it on the screen instead... + (tv:sheet-draw-glyph index font x y + (if (eq color (medium-foreground stream)) + (tv:sheet-char-aluf window) + (sheet-decode-color (follow-indirect-ink color stream) + stream nil)) + window)))))) + +(defmethod stream-write-string-1 ((stream sheet-implementation-mixin) + glyph-buffer start end font color x y) + (when (<= end start) (return-from stream-write-string-1)) + (let ((window (slot-value stream 'window))) + (when (window-drawing-possible stream) + (tv:prepare-sheet (window) + (let ((glyph-buffer glyph-buffer) + (index start) + (index8 0) + (x (+ x (tv:sheet-left-margin-size window))) + (y (+ y (tv:sheet-top-margin-size window)))) + (declare (sys:array-register glyph-buffer)) + (sys:with-stack-array (glyphs8 (- end start) :element-type 'string-char) + (declare (sys:array-register glyphs8)) + (loop + (when (= index end) (return)) + (setf (aref glyphs8 index8) (code-char (aref glyph-buffer index))) + (incf index) + (incf index8)) + (tv:sheet-draw-string window + (if (eq color (medium-foreground stream)) + (tv:sheet-char-aluf window) + (sheet-decode-color (follow-indirect-ink color stream) + stream nil)) + x y glyphs8 font 0 index8 + (tv:sheet-width window)))))))) + + +(defmethod text-style-height ((text-style standard-text-style) + (stream sheet-implementation-mixin)) + (with-slots (display-device-type window) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (sys:font-char-height font)))) + +(defmethod text-style-width ((text-style standard-text-style) + (stream sheet-implementation-mixin)) + (with-slots (display-device-type window) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (sys:font-char-width font)))) + +(defmethod text-style-ascent ((text-style standard-text-style) + (stream sheet-implementation-mixin)) + (with-slots (display-device-type window) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (let* ((height (sys:font-char-height font)) + (descent (- height (sys:font-baseline font))) + (ascent (- height descent))) + ascent)))) + +(defmethod text-style-descent ((text-style standard-text-style) + (stream sheet-implementation-mixin)) + (with-slots (display-device-type window) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (let* ((height (sys:font-char-height font)) + (descent (- height (sys:font-baseline font)))) + descent)))) + +(defmethod text-style-fixed-width-p ((text-style standard-text-style) + (stream sheet-implementation-mixin)) + (with-slots (display-device-type window) stream + (let ((font (text-style-mapping + display-device-type *standard-character-set* text-style window))) + (null (sys:font-char-width-table font))))) + +(defmethod text-size ((stream sheet-implementation-mixin) string + &key (text-style (stream-merged-text-style stream)) (start 0) end) + (when (characterp string) + (setq string (string string) + start 0 + end nil)) + (multiple-value-bind (last-x largest-x last-y total-height baseline) + (stream-string-output-size stream string :text-style text-style :start start :end end) + (values largest-x total-height last-x last-y baseline))) + + +;;; This whole file is #+Genera, right? + +(scl:defflavor clim-sheet + ((selected-inferior nil)) + (dw::margin-mixin ;scroll bars, labels, borders + tv:no-screen-managing-mixin ;don't auto-select a pane + tv:window) + (:default-init-plist :borders nil + :save-bits nil ;adjusted later if top-level + :deexposed-typeout-action :permit + :blinker-p nil + :label nil)) + +(scl:defflavor temp-clim-sheet + () + (tv:temporary-window-mixin clim-sheet)) + +;; All the sheet windows in a given activity (top level window) share the same io-buffer, and +;; CLIM decides which CLIM window to give the input to. +;; A top-level window should have a bit save array if we want the screen manager +;; to do what users expect. +(scl:defmethod (:init clim-sheet :before) (args) + (declare (ignore args)) + (let ((top-level (not (typep tv:superior 'clim-sheet)))) + (unless tv:io-buffer + (setq tv:io-buffer (if top-level + (tv:make-io-buffer 100) + (scl:send tv:superior :io-buffer)))) + (when top-level + ;; This is like :save-bits :delayed + (setf (tv:sheet-save-bits) 1)))) + +(scl:defmethod (:init temp-clim-sheet :after) (args) + (declare (ignore args)) + (setf (tv:sheet-save-bits) 0)) + +;;; Interface to Genera scroll bars. +(scl:defmethod (:y-scroll-position clim-sheet) () + (declare (values top-displayed height-displayed minimum-y maximum-y)) + (let* ((stream (clim-window-for-host-window scl:self :error-if-no-match nil)) + (history (and stream (stream-output-history stream))) + (viewport (and stream (window-viewport stream)))) + (cond ((and viewport history) + (with-bounding-rectangle* (vleft vtop vright vbottom) viewport + (declare (ignore vleft vright)) + (with-bounding-rectangle* (hleft htop hright hbottom) history + (declare (ignore hleft hright)) + (values vtop (- vbottom vtop) htop hbottom)))) + (t (values 0 0 0 0))))) + +(scl:defmethod (:x-scroll-position clim-sheet) () + (let* ((stream (clim-window-for-host-window scl:self :error-if-no-match nil)) + (history (and stream (stream-output-history stream))) + (viewport (and stream (window-viewport stream)))) + (cond ((and viewport history) + (with-bounding-rectangle* (vleft vtop vright vbottom) viewport + (declare (ignore vtop vbottom)) + (with-bounding-rectangle* (hleft htop hright hbottom) history + (declare (ignore htop hbottom)) + (values vleft (- vright vleft) hleft hright)))) + (t (values 0 0 0 0))))) + +(defun calculate-new-viewport-position (stream x-or-y type position + &optional (context-nlines 1)) + (declare (ignore context-nlines)) + (declare (values viewport-left viewport-top)) + (let ((viewport (window-viewport stream))) + (ecase x-or-y + (:y + (ecase type + (:relative-jump + (values (bounding-rectangle-left viewport) + (+ (bounding-rectangle-top viewport) + (* position (stream-line-height stream)))) + #+Ignore + (unless (zerop position) + (let ((index viewport-displayed-strings-start-index) + (max-index (fill-pointer displayed-strings)) + (y (box-top cursor-viewport)) + (inc (signum position))) + (labels ((index-ok-p (index) + (and ( index 0) + (< index max-index)))) + (loop repeat (abs position) + do (loop doing + (let ((new-index (+ index inc))) + (unless (index-ok-p new-index) + (loop-finish)) + (setq index new-index)) + (let ((new-top (box-top (presentation-displayed-box + (aref displayed-strings index))))) + (when ( new-top y) + (setq y new-top) + (loop-finish)))) + while (index-ok-p index)) + (when (index-ok-p index) + (let ((new-top (box-top (presentation-displayed-box + (aref displayed-strings index))))) + (values (box-left cursor-viewport) new-top))))))) + (:relative + (values (bounding-rectangle-left viewport) + (+ position (bounding-rectangle-top viewport)))) + (:absolute + (values (bounding-rectangle-left viewport) + position)) + (:screenful + (with-bounding-rectangle* (vleft vtop vright vbottom) viewport + (declare (ignore vright)) + (let ((new-top (+ vtop (* position (- vbottom vtop))))) + (setq new-top (min new-top (- vbottom vtop))) + (values vleft new-top)))) + )) + (:x + (ecase type + (:relative-jump + (calculate-new-viewport-position + stream :x :relative + (* position (stream-character-width stream #\Space)))) + (:relative + (values (+ (bounding-rectangle-left viewport) position) + (bounding-rectangle-top viewport))) + (:absolute + (values position + (bounding-rectangle-top viewport)))))))) + +(scl:defmethod (:y-scroll-to clim-sheet) (position type) + (let* ((stream (clim-window-for-host-window scl:self)) + (history (stream-output-history stream)) + (left (bounding-rectangle-left (window-viewport stream)))) + (multiple-value-bind (ignore top) + (calculate-new-viewport-position stream :y type position) + (declare (ignore ignore)) + (when history + (with-bounding-rectangle* (hleft htop hright hbottom) history + (declare (ignore hleft hright)) + (setq top (min (max htop top) hbottom)))) + (window-set-viewport-position* stream left top)))) + +(scl:defmethod (:x-scroll-to clim-sheet) (position type) + (let* ((stream (clim-window-for-host-window scl:self)) + (history (stream-output-history stream)) + (top (bounding-rectangle-top (window-viewport stream)))) + (let ((left (calculate-new-viewport-position stream :x type position))) + (when history + (with-bounding-rectangle* (hleft htop hright hbottom) history + (declare (ignore htop hbottom)) + (setq left (min (max left hleft) hright)))) + (window-set-viewport-position* stream left top)))) + +;;; The window manager should manipulate the highest "CLIM sheet" when invoked +;;; on an inferior. +(scl:defmethod (:alias-for-selected-windows clim-sheet) () + (if (typep tv:superior 'clim-sheet) + (scl:send tv:superior :alias-for-selected-windows) + scl:self)) + +(scl:defmethod (:name-for-selection clim-sheet) () + (or (let ((frame (window-stream-to-frame (clim-window-for-host-window scl:self)))) + (and frame (frame-pretty-name frame))) + (let ((label (scl:send scl:self :label))) + (and label (scl:string-search-not-char #\sp label) label)) + tv:name)) + +;;; A combination of the methods of pane-mixin and basic-frame +(scl:defwhopper (:select clim-sheet) (&rest args) + (when (scl:send tv:superior :inferior-select scl:self) + (cond ((and selected-inferior + (scl:send selected-inferior :exposed-p)) + (scl:lexpr-send selected-inferior :select args)) + ((and (null selected-inferior) + tv:inferiors + (let ((frame (window-stream-to-frame (clim-window-for-host-window scl:self)))) + (when frame + ;; This is a frame whose input focus has not yet been directed to any pane + ;; Choose the interactor pane by default + (let ((stream (frame-query-io frame))) + (when stream + (scl:lexpr-send (slot-value stream 'window) :select args) + t)))))) + (t + (scl:lexpr-continue-whopper args))))) + +;;; As for basic-frame +(scl:defmethod (:inferior-select clim-sheet) (pane) + (setq selected-inferior pane) + (scl:send tv:superior :inferior-select scl:self)) + +;;; As for basic-frame +(scl:defwhopper (:select-relative clim-sheet) () + (if (and selected-inferior + (scl:send selected-inferior :exposed-p)) + (scl:send selected-inferior :select-relative) + (scl:continue-whopper))) + +;;; As for pane-mixin +;;; "When selecting a pane with the mouse, pass the selection request to the frame." +(scl:defwhopper (:mouse-select clim-sheet) (&rest args) + (if (typep tv:superior 'clim-sheet) + (scl:lexpr-send tv:superior ':mouse-select args) + (scl:lexpr-continue-whopper args))) + +(scl:defmethod (:expose clim-sheet :after) (&rest args) + (declare (ignore args)) + (scl:send tv:superior :inferior-expose scl:self)) + +(scl:defmethod (:inferior-expose clim-sheet) (inferior) + (when (eq inferior selected-inferior) + (scl:send inferior :select-relative))) + +(scl:defmethod (tv:refresh-rectangle clim-sheet) (left top right bottom) + (let ((window (clim-window-for-host-window scl:self))) + (setf (slot-value window 'highlighted-presentation) nil) + (multiple-value-bind (viewport-x viewport-y) + (bounding-rectangle-position* (window-viewport window)) + (frame-replay *application-frame* + window (make-bounding-rectangle (+ left viewport-x) + (+ top viewport-y) + (+ right viewport-x) + (+ bottom viewport-y)))) + (tv:refresh-margins-rectangle scl:self left top right bottom))) + +;;; This is a hideous kludge that attempts to address the problems with moving windows +;;; within their parents. +(scl:defwhopper (:set-position clim-sheet) (new-x new-y &optional verify) + (ecase verify + ((:verify) + (scl:continue-whopper new-x new-y verify)) + ((nil) + (let ((old-x tv:x-offset) (old-y tv:y-offset)) + (multiple-value-prog1 (scl:continue-whopper new-x new-y verify) + (unless (or *synchronous-window-operation-being-processed* + (and (= old-x tv:x-offset) (= old-y tv:y-offset))) + (scl:send scl:self :force-kbd-input + (make-window-size-or-position-change-event + (clim-window-for-host-window scl:self) + nil nil nil nil)))))))) + +(scl:defmethod (:refresh clim-sheet :before) (&optional (type :complete-redisplay)) + (declare (ignore type)) + (let ((stream (clim-window-for-host-window scl:self))) + ;; Invalidate all cached inks, so they'll be redecoded taking into account any + ;; changed parameters such as reversed video. + (let ((cache (slot-value stream 'ink-cache))) + (dotimes (i (array-total-size cache)) + (setf (aref cache i) nil))) + (let ((foreground (sheet-decode-color (medium-foreground stream) stream nil)) + (background (sheet-decode-color (medium-background stream) stream nil))) + (funcall scl:self :set-char-aluf foreground) + (funcall scl:self :set-erase-aluf background)))) + +(scl:defmethod (:refresh clim-sheet :after) (&optional (type :complete-redisplay)) + (declare (ignore type)) + (let ((window (clim-window-for-host-window scl:self))) + (setf (slot-value window 'highlighted-presentation) nil) + (unless *sizing-application-frame* ;avoid replaying twice + (frame-replay *application-frame* window (window-viewport window))))) + +(scl:defwhopper (:change-of-size-or-margins clim-sheet) (&rest args) + (let ((old-x tv:x-offset) (old-y tv:y-offset) + (old-width tv:width) (old-height tv:height)) + (multiple-value-prog1 (scl:lexpr-continue-whopper args) + (unless (or *synchronous-window-operation-being-processed* + (and (= old-x tv:x-offset) (= old-y tv:y-offset) + (= old-width tv:width) (= old-height tv:height))) + (scl:send scl:self :force-kbd-input + (make-window-size-or-position-change-event + (clim-window-for-host-window scl:self) + nil nil nil nil)))))) + +(scl:defwhopper (:set-reverse-video-p clim-sheet) (reverse-video-p) + (let ((old-reverse-video-p (scl:send scl:self :reverse-video-p))) + (multiple-value-prog1 + (scl:continue-whopper reverse-video-p) + (unless (eql reverse-video-p old-reverse-video-p) + (labels ((switch-inks (window) + ;; Inhibit refreshing until we're done + (rotatef (slot-value window 'foreground) + (slot-value window 'background)) + (dolist (window (window-children window)) + (switch-inks window)))) + (declare (dynamic-extent #'switch-inks)) + (switch-inks (clim-window-for-host-window scl:self)) + (scl:send scl:self :refresh)))))) + +(scl:defmethod (:convert-mouse-coords clim-sheet) (x y in-or-out) + (case in-or-out + (:in (values (- x tv:left-margin-size) + (- y tv:top-margin-size))) + (:out (values (+ x tv:left-margin-size) + (+ y tv:top-margin-size))))) + +(scl:defmethod (with-clim-sheet-clipping-region clim-sheet) + (left top right bottom continuation stream) + (tv:with-sheet-clipping-region ((+ left tv:left-margin-size) (+ top tv:top-margin-size) + (+ right tv:left-margin-size) (+ bottom tv:top-margin-size)) + (declare (sys:downward-function)) ;yecch + (funcall continuation stream))) + +(scl:compile-flavor-methods clim-sheet temp-clim-sheet) + + +;;; + +(defclass sheet-window-stream + (sheet-implementation-mixin window-stream) + () + (:default-initargs :display-device-type nil + :text-cursor (make-instance 'sheet-text-cursor))) + +(defun create-sheet-root-window (&key (screen tv:main-screen)) + (make-instance 'sheet-window-stream + :window screen + :label nil + :scroll-bars nil + :display-device-type + (let (#+IMach (device (scl:send screen :display-device-type))) + (cond + #+IMach + ((and (find-package 'mtb) + (typep device + (intern "SMALL-SCREEN-GENERA-FONTS-MAC-DISPLAY-DEVICE" 'mtb))) + *small-sheet-device*) + (t *sheet-device*))))) + + +;; :SHEET and :GENERA are the same thing... +(define-implementation :sheet 'create-sheet-root-window) +(define-implementation :genera 'create-sheet-root-window) + +(defmethod initialize-instance :after ((stream sheet-window-stream) + &key parent left top right bottom label + (scroll-bars ':both) (borders t) + window save-under) + ;; --- can we do this error checking more generally? + (cond ((null parent) + ;; :PARENT NIL means open the root window. + (unless window + (error "You must supply a parent window stream or explicitly initilize the WINDOW slot.")) + ;; parent nil means + (when (or left top right bottom) + (error "You cannot specify the size of the root window (i.e. when :PARENT is NIL).")) + (with-slots (left top right bottom) stream + (multiple-value-bind (w h) (scl:send window :size) + (setf left (tv:sheet-x window) + top (tv:sheet-y window) + right (+ (tv:sheet-x window) w) + bottom (+ (tv:sheet-y window) h)))) + (setf (stream-pointers stream) + (list (make-instance 'standard-pointer :root stream)))) + (t + (with-slots (display-device-type) stream + (unless display-device-type + (setf display-device-type (slot-value parent 'display-device-type)))) + ;; When parent is supplied, open an inferior + (unless (and left top right bottom) + (error "You must supply :left :top :right and :bottom when creating a window")) + (let ((parent-window (slot-value parent 'window))) + (when parent-window + (multiple-value-bind (wl wt) + (scl:send parent-window :inside-edges) + (translate-positions wl wt left top right bottom))) + (let ((sheet (tv:make-window (if save-under 'temp-clim-sheet 'clim-sheet) + :superior parent-window + :left left ;see above + :top top + :right right + :bottom bottom + ;; :edges (list left top right bottom) + :margin-components (clim-sheet-margin-components + label scroll-bars borders)))) + (setf (slot-value stream 'window) sheet) + (setf (slot-value stream 'color-p) (color:color-stream-p sheet)) + ;; EMBEDDED-P indicates that the screen implementation has fast, specific + ;; methods for implementing the Genera graphics substrate. I'm not sure + ;; if the use of basic-remote-screen is the right test, but it's quick... + (setf (slot-value stream 'embedded-p) + (typep (tv:sheet-screen sheet) 'tv:basic-remote-screen)) + (scl:send sheet :set-char-aluf + (sheet-decode-color (medium-foreground stream) stream nil)) + (scl:send sheet :set-erase-aluf + (sheet-decode-color (medium-background stream) stream nil)))))) + (associate-clim-window-with-host-window (slot-value stream 'window) stream)) + +;;; The margin stuff seems to have changed. +(defmethod initialize-instance :around ((stream sheet-window-stream) &key label) + (call-next-method) + (when (slot-value stream 'parent) + (scl:send (slot-value stream 'window) :set-label " ") + (scl:send (slot-value stream 'window) + :set-label (clim-label->genera-label label stream)))) + +(defmethod (setf medium-foreground) :after (ink (stream sheet-window-stream)) + (with-slots (window) stream + (scl:send window :set-char-aluf (sheet-decode-color ink stream nil)) + (scl:send window :refresh))) + +(defmethod (setf medium-background) :after (ink (stream sheet-window-stream)) + (with-slots (window) stream + (scl:send window :set-erase-aluf (sheet-decode-color ink stream nil)) + (scl:send window :refresh))) + +(defun clim-sheet-margin-components (label-p scroll-bar borders-p) + `(,@(and borders-p + '((dw::margin-borders ))) + ,@(and (member scroll-bar '(:vertical :both)) + '((dw::margin-scroll-bar :history-noun "history"))) + ,@(and (member scroll-bar '(:horizontal :both)) + '((dw::margin-scroll-bar :margin :bottom :history-noun "history"))) + ,@(and borders-p + '((dw::margin-white-borders :thickness 2))) + ,@(and label-p + '((dw::margin-label ))))) + +;;; Since sheets have no concept of a "region", we'll just use a Y rectangle +;;; to represent one. + +;;--- This should clip to real regions, not just to bounding-rectangles +(defmethod invoke-with-clipping-region + ((stream sheet-implementation-mixin) continuation (region standard-bounding-rectangle)) + (let ((window (slot-value stream 'window))) + (multiple-value-bind (vx vy) (window-viewport-position* stream) + (declare (type coordinate vx vy)) + (multiple-value-bind (ml mt) (window-margins stream) + (declare (type coordinate ml mt)) + (with-bounding-rectangle* (left top right bottom) region + ;;--- where should this FIXing be done? + (fix-points left top right bottom vx vy ml mt) + (with-clim-sheet-clipping-region window + (+ (- left vx) ml) (+ (- top vy) mt) + (+ (- right vx) ml) (+ (- bottom vy) mt) + continuation stream)))))) + + +;;; Input side + +(defmethod stream-clear-input :after ((stream sheet-window-stream)) + (with-slots (window) stream + (scl:send window :clear-input))) + +(defun mouse-char-bits->modifier-state (bits) + (let ((mask 0)) + (macrolet ((do-shift (shift) + `(when (si:bit-test (si:name-bit ,shift) bits) + (let ((bit (modifier-key-index ,shift))) + (setf mask (dpb 1 (byte 1 bit) mask)))))) + ;; why is SHIFT different from sys:%kbd-shifts-shift + (when (ldb-test (byte 1 4) bits) + (let ((bit (modifier-key-index :shift))) + (setf mask (dpb 1 (byte 1 bit) mask)))) + (do-shift :control) + (do-shift :meta) + (do-shift :super) + (do-shift :hyper)) + mask)) + +(defmethod window-modifier-state ((stream sheet-implementation-mixin)) + (let* ((window (slot-value stream 'window)) + (mouse (tv:sheet-mouse window))) + (let ((shifts (tv:mouse-chord-shifts mouse))) + (mouse-char-bits->modifier-state shifts)))) + +(defmethod set-pointer-window-and-location ((stream sheet-window-stream) pointer) + (let ((mouse (tv:sheet-mouse (slot-value stream 'window)))) + (setf (pointer-window pointer) + (clim-window-for-host-window (tv:window-under-mouse-internal mouse) + :error-if-no-match nil)) + (pointer-set-position* pointer (tv:mouse-x mouse) (tv:mouse-y mouse)))) + +(defmethod stream-event-handler ((stream sheet-window-stream) + &key (timeout nil) (input-wait-test nil)) + ;;--- Have to establish correspondence between pointing devices and pointer objects + (with-slots (window) stream + (let* ((sys:rubout-handler nil) + (mouse (tv:sheet-mouse window)) + (pointer (stream-primary-pointer stream)) + (old-buttons (tv:mouse-last-buttons mouse)) + (old-x (pointer-x-position pointer)) + (old-y (pointer-y-position pointer)) + ;;--- Why doesn't the pointer object remember these? + (old-shifts (tv:mouse-chord-shifts mouse)) + (old-window (pointer-window pointer)) + (what-happened (if timeout :timeout :mouse-motion)) + ;; If we're inside an encapsulating stream, such as the input editor, and a window + ;; resizing event is received, don't get confused while handling the event + (*original-stream* nil)) + (labels ((mouse-motion-pending () + (or (/= (tv:mouse-chord-shifts mouse) old-shifts) + (/= old-buttons (tv:mouse-last-buttons mouse)) + (/= old-x (mouse-x)) + (/= old-y (mouse-y)) + (not (eql old-window (clim-window-for-host-window + (tv:window-under-mouse-internal mouse) + :error-if-no-match nil))))) + (something-pending (sheet) + (cond ((not (tv:sheet-console window)) nil) ;wait for console + ((not (tv:mouse-sheet mouse)) nil) ;.. + ((and input-wait-test (funcall input-wait-test stream)) + (setq what-happened :input-wait-test)) + ((mouse-motion-pending) + (setq what-happened :mouse-motion) + T) + ((scl:send-if-handles sheet :listen) + (setq what-happened :listen) + T))) + (mouse-x () (tv:mouse-x mouse)) + (mouse-y () (tv:mouse-y mouse))) + (declare (dynamic-extent #'mouse-motion-pending #'something-pending + #'mouse-x #'mouse-y)) + (cond ((eql timeout 0) ;avoid consing bignums + (something-pending window)) + (timeout + (scl:process-wait-with-timeout si:*whostate-awaiting-user-input* (* timeout 60) + #'something-pending window)) + (t + (scl:process-wait si:*whostate-awaiting-user-input* + #'something-pending window))) + (ecase what-happened + (:listen + (let ((character (scl:send window :any-tyi))) + (cond ((typep character 'window-size-or-position-change-event) + (let* ((window (event-window character)) + (window-win (slot-value window 'window)) + (parent (window-parent window)) + (parent-win (slot-value parent 'window))) + (multiple-value-bind (left top right bottom) + (scl:send window-win :edges) + (when (null (tv:sheet-superior parent-win)) + (multiple-value-bind (wl wt) + (scl:send parent-win :inside-edges) + (translate-positions (- wl) (- wt) left top right bottom))) + (window-note-size-or-position-change + window left top right bottom)))) + ((listp character) + (case (first character) + (:mouse-button + (scl:destructuring-bind (blip-type char mouse-window x y) character + (declare (ignore blip-type)) + (setf (pointer-button-state pointer) + (tv:mouse-last-buttons mouse)) + ;; we don't need to translate x and y by the root-offsets + ;; because they're already in window coordinates... + (let ((pw (clim-window-for-host-window mouse-window))) + (setf (pointer-window pointer) pw) + (multiple-value-bind (xm ym) (scl:send mouse-window :margins) + ;; X and Y are presumed to be fixnums here + (stream-note-pointer-button-press + pw pointer (ash 1 (si:mouse-char-button char)) + (mouse-char-bits->modifier-state (si:mouse-char-bits char)) + (- x xm) (- y ym)))))))) + (t (queue-put (stream-input-buffer stream) character))))) + (:mouse-motion + ;; --- + (pointer-set-position* pointer (mouse-x) (mouse-y)) + (let ((window (clim-window-for-host-window (tv:window-under-mouse-internal mouse) + :error-if-no-match nil))) + (setf (pointer-window pointer) window) + (when window + (setf (pointer-motion-pending window pointer) T)))) + (:input-wait-test :input-wait-test) + (:timeout :timeout)) + what-happened)))) + +(defmethod set-stream-pointer-in-screen-coordinates ((stream sheet-window-stream) pointer x y) + (declare (ignore pointer)) ;Sigh. + (let ((mouse (tv:sheet-mouse (slot-value stream 'window)))) + (tv:mouse-warp x y mouse))) + +(defmethod stream-pointer-input-rectangle* ((stream sheet-window-stream) pointer + &key left top right bottom) + (declare (ignore pointer)) + (multiple-value-bind (dx dy) (window-viewport-position* stream) + (setq left (if (typep left 'real) (round left) dx)) + (setq top (if (typep top 'real) (round top) dy)) + (setq right (if (typep right 'real) (round right) (+ left 50))) + (setq bottom (if (typep bottom 'real) (round bottom) (+ top 50))) + ;; TV:MOUSE-RESHAPE-RECTANGLE deals with values in TV:MAIN-SCREEN coordinates. + (multiple-value-bind (lm tm) (window-offset stream) + (decf dx lm) + (decf dy tm)) + (multiple-value-bind (bleft btop bright bbottom) + (dw::box-edges + (tv:mouse-reshape-rectangle + :initial-box (dw:make-box (- left dx) (- top dy) (- right dx) (- bottom dy)) + :sheet (slot-value stream 'window))) + (values (+ bleft dx) + (+ btop dy) + (+ bright dx) + (+ bbottom dy))))) + +(defmethod mouse-documentation-window ((window sheet-implementation-mixin)) + (let ((console (tv:sheet-console (slot-value window 'window)))) + (if (eq console sys:*main-console*) + tv:who-line-documentation-window + (let ((who-screen (tv:console-who-line-screen console))) + (and who-screen + (tv:get-who-line-field :mouse-documentation who-screen)))))) + + +;;; Text styles for sheets + +(defclass sheet-device (display-device) ()) + +(defmethod text-style-mapping :around + ((display-device sheet-device) character-set style &optional window) + (declare (ignore window)) + (let* ((font-symbol (call-next-method)) + (font (if (symbolp font-symbol) (symbol-value font-symbol) font-symbol))) + (unless (typep font 'sys:font) + (error "Mapping for ~A characters in ~A character set is not a font" + style character-set)) + font)) + +(defparameter *sheet-logical-size-alist* + '((:tiny 6) + (:very-small 8) + (:small 10) + (:normal 12) + (:large 14) + (:very-large 20) + (:huge 24))) + +(defmethod standardize-text-style ((display-device sheet-device) character-set style) + (standardize-text-style-1 + display-device style character-set *sheet-logical-size-alist*)) + +(define-display-device *sheet-device* sheet-device + :font-for-undefined-style fonts:boxfont) + +(define-text-style-mappings *sheet-device* *standard-character-set* + (:family :fix (:face :roman (:size 20 fonts:bigfnt + 14 fonts:medfnt + 12 fonts:cptfont + 10 fonts:tvfont + 8 fonts:einy7 + 6 fonts:tiny) + :italic (:size 20 fonts:bigfnti + 14 fonts:medfnti + 12 fonts:cptfonti + 10 fonts:tvfonti + 8 fonts:einy7 + 6 fonts:tiny) + :bold (:size 20 fonts:bigfntb + 14 fonts:medfntb + 12 fonts:cptfontcb + 10 fonts:tvfontb + 8 fonts:einy7 + 6 fonts:tiny) + (:bold :italic) (:size 20 fonts:bigfntbi + 14 fonts:medfntbi + 12 fonts:cptfontbi + 10 fonts:tvfontbi + 8 fonts:einy7 + 6 fonts:tiny) + (:bold :extended) (:size 12 fonts:cptfontb + 10 fonts:tvfontb) + :condensed (:size 12 fonts:cptfontc) + (:extra :condensed) (:size 12 fonts:cptfontcc + 10 fonts:tvfont)))) + +(define-text-style-mappings *sheet-device* *standard-character-set* + (:family :serif (:face :roman (:size 20 fonts:dutch20 + 14 fonts:dutch14 + 12 fonts:tr12 + 10 fonts:tr10 + 8 fonts:tr8) + :italic (:size 20 fonts:dutch20I + 14 fonts:dutch14I + 12 fonts:tr12I + 10 fonts:tr10I + 8 fonts:tr8I) + :bold (:size 20 fonts:dutch20B + 14 fonts:dutch14B + 12 fonts:tr12B + 10 fonts:tr10B + 8 fonts:tr8B) + (:bold :italic) (:size 20 fonts:dutch20BI + 14 fonts:dutch14BI + 12 fonts:tr12BI + 10 fonts:tr10BI + 8 fonts:tr8BI)))) + +(define-text-style-mappings *sheet-device* *standard-character-set* + (:family :sans-serif (:face :roman (:size 20 fonts:swiss20 + 14 fonts:hl14 + 12 fonts:hl12 + 10 fonts:hl10 + 8 fonts:hl8) + :italic (:size 20 fonts:swiss20I + 14 fonts:hl14I + 12 fonts:hl12I + 10 fonts:hl10I + 8 fonts:hl8I) + :bold (:size 20 fonts:swiss20B + 14 fonts:hl14B + 12 fonts:hl12B + 10 fonts:hl10B + 8 fonts:hl8B) + (:bold :italic) (:size 20 fonts:swiss20BI + 14 fonts:hl14BI + 12 fonts:hl12BI + 10 fonts:hl10BI + 8 fonts:hl8BI)))) + +#+IMach +(defclass small-sheet-device (sheet-device) ()) + +#+IMach +(defparameter *small-sheet-logical-size-alist* + '((:tiny 6) + (:very-small 8) + (:small 10) + (:normal 12) + (:large 14) + (:very-large 20) + (:huge 24))) + +#+IMach +(defmethod standardize-text-style ((display-device small-sheet-device) character-set style) + (standardize-text-style-1 + display-device style character-set *small-sheet-logical-size-alist*)) + +#+IMach +(define-display-device *small-sheet-device* small-sheet-device + :font-for-undefined-style fonts:boxfont) + +#+IMach +(define-text-style-mappings *small-sheet-device* *standard-character-set* + (:family :fix (:face :roman (:size 20 fonts:medfnt + 14 fonts:cptfont + 12 fonts:tvfont + 10 fonts:einy7 + 8 fonts:einy7 + 6 fonts:einy7) + :italic (:size 20 fonts:medfnti + 14 fonts:cptfonti + 12 fonts:tvfonti + 10 fonts:einy7 + 8 fonts:einy7 + 6 fonts:einy7) + :bold (:size 20 fonts:medfntb + 14 fonts:cptfontcb + 12 fonts:tvfontb + 10 fonts:einy7 + 8 fonts:einy7 + 6 fonts:einy7) + (:bold :italic) (:size 20 fonts:medfntbi + 14 fonts:cptfontbi + 12 fonts:tvfontbi + 10 fonts:einy7 + 8 fonts:einy7 + 6 fonts:einy7) + (:bold :extended) (:size 12 fonts:tvfontb + 10 fonts:cptfontb) + :condensed (:size 12 fonts:cptfontc) + (:extra :condensed) (:size 12 fonts:cptfontcc + 10 fonts:tvfont)))) + +#+IMach +(define-text-style-mappings *small-sheet-device* *standard-character-set* + (:family :serif (:face :roman (:size 20 fonts:dutch14 + 14 fonts:tr12 + 12 fonts:tr10 + 10 fonts:tr8 + 8 fonts:tr8) + :italic (:size 20 fonts:dutch14I + 14 fonts:tr12I + 12 fonts:tr10I + 10 fonts:tr8I + 8 fonts:tr8I) + :bold (:size 20 fonts:dutch14B + 14 fonts:tr12B + 12 fonts:tr10B + 10 fonts:tr8B + 8 fonts:tr8B) + (:bold :italic) (:size 20 fonts:dutch14BI + 14 fonts:tr12BI + 12 fonts:tr10BI + 10 fonts:tr8BI + 8 fonts:tr8BI)))) + +#+IMach +(define-text-style-mappings *small-sheet-device* *standard-character-set* + (:family :sans-serif (:face :roman (:size 20 fonts:hl14 + 14 fonts:hl12 + 12 fonts:hl10 + 10 fonts:hl8 + 8 fonts:hl8) + :italic (:size 20 fonts:hl14I + 14 fonts:hl12I + 12 fonts:hl10I + 10 fonts:hl8I + 8 fonts:hl8I) + :bold (:size 20 fonts:hl14B + 14 fonts:hl12B + 12 fonts:hl10B + 10 fonts:hl8B + 8 fonts:hl8B) + (:bold :italic) (:size 20 fonts:hl14BI + 14 fonts:hl12BI + 12 fonts:hl10BI + 10 fonts:hl8BI + 8 fonts:hl8BI)))) + + +;;; Text Cursors for sheets + +(defclass sheet-text-cursor + (cursor) + ((x :initarg :x :initform 0) ;needed if cursor is scrolled off viewport + (y :initarg :y :initform 0) + (stream :initarg :stream) + (active :initform nil) ;false if visibility is :inactive + (blinker :initform nil))) ;Genera window system blinker to be used + +(defmethod cursor-active-p ((cursor sheet-text-cursor)) + (not (null (slot-value cursor 'active)))) + +(defmethod (setf cursor-stream) (new-value (cursor sheet-text-cursor)) + (setf (slot-value cursor 'stream) new-value) + (let ((blinker (slot-value cursor 'blinker))) + (when blinker + (tv:blinker-set-sheet blinker (slot-value new-value 'window)))) + new-value) + +#-Silica +(defmethod cursor-position* ((cursor sheet-text-cursor)) + (values (slot-value cursor 'x) (slot-value cursor 'y))) + +#-Silica +(defmethod cursor-set-position* ((cursor sheet-text-cursor) x y) + (setf (slot-value cursor 'x) x + (slot-value cursor 'y) y) + (let ((blinker (slot-value cursor 'blinker))) + (when blinker + (multiple-value-bind (x y) + (drawing-surface-to-viewport-coordinates (slot-value cursor 'stream) x y) + (tv:blinker-set-cursorpos blinker x y))))) + +(defmethod cursor-visibility ((cursor sheet-text-cursor)) + (let ((active (slot-value cursor 'active)) + (blinker (slot-value cursor 'blinker))) + (cond ((not active) :inactive) + ((not blinker) :off) + ((member (tv:blinker-visibility blinker) '(:blink :on t)) :on) + (t :off)))) + +(defmethod (setf cursor-visibility) (new-visibility (cursor sheet-text-cursor)) + (setf (slot-value cursor 'active) (not (eq new-visibility :inactive))) + (let ((stream (slot-value cursor 'stream)) + (blinker (slot-value cursor 'blinker))) + (when (and (null blinker) (eq new-visibility :on)) + ;; It isn't safe to create the blinker any earlier than this, because of the + ;; order of initializations while creating a sheet-window-stream + (setq blinker + (setf (slot-value cursor 'blinker) + (flavor:make-instance 'tv:rectangular-blinker + :sheet (slot-value stream 'window) + :visibility nil + :deselected-visibility nil + :follow-p nil))) + (multiple-value-bind (x y) + (drawing-surface-to-viewport-coordinates stream (slot-value cursor 'x) + (slot-value cursor 'y)) + (tv:blinker-set-cursorpos blinker x y))) + (when blinker + (tv:blinker-set-visibility blinker (if (eq new-visibility :on) + (if (tv:sheet-selected-p + (slot-value stream 'window)) + :blink + :on) + nil)) + (scl:send blinker :set-deselected-visibility (if (eq new-visibility :on) :on nil)))) + new-visibility) + +;; The window system draws it, so we don't have to +(defmethod draw-cursor ((cursor sheet-text-cursor) on-p) + on-p) diff --git a/pre-silica/graphics-generics.lisp b/pre-silica/graphics-generics.lisp new file mode 100644 index 00000000..b4635645 --- /dev/null +++ b/pre-silica/graphics-generics.lisp @@ -0,0 +1,387 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: graphics-generics.lisp,v 1.4 91/03/26 12:48:01 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." + +(define-graphics-operation draw-point (x y) + :arguments ((point x y)) + :drawing-options :point + :method-body + (with-transformed-arguments + (draw-point-internal stream 0 0 x y + (medium-ink stream) (medium-line-style stream)))) + +(defun draw-points (stream point-seq &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream point-seq &key . #.(all-drawing-options-lambda-list :point))) + (flet ((trampoline () + (if (listp point-seq) + (loop + (when (null point-seq) (return)) + (let ((point (pop point-seq))) + (draw-point-method stream (point-x point) (point-y point)))) + (do ((i 0 (+ i 1))) + ((= i (length point-seq))) + (let ((point (aref point-seq i))) + (draw-point-method stream (point-x point) (point-y point))))))) + (declare (dynamic-extent #'trampoline)) + (if args + (apply #'invoke-with-drawing-options stream #'trampoline args) + (trampoline)))) + +(defun draw-points* (stream coord-seq &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream coord-seq &key . #.(all-drawing-options-lambda-list :point))) + (flet ((trampoline () + (if (listp coord-seq) + (loop + (when (null coord-seq) (return)) + (draw-point-method stream (pop coord-seq) (pop coord-seq))) + (do ((i 0 (+ i 2))) + ((= i (length coord-seq))) + (draw-point-method stream (aref coord-seq i) (aref coord-seq (1+ i))))))) + (declare (dynamic-extent #'trampoline)) + (if args + (apply #'invoke-with-drawing-options stream #'trampoline args) + (trampoline)))) + +;; QuickDraw and X support a drawing state with a pattern, thickness at the lowest +;; level. Only Genera needs to turn lines into rectangles or polygons. +(define-graphics-operation draw-line (x1 y1 x2 y2) + :arguments ((point x1 y1 x2 y2)) + :drawing-options :line-cap + :method-body + (with-transformed-arguments + (draw-line-internal stream 0 0 x1 y1 x2 y2 + (medium-ink stream) (medium-line-style stream)))) + +(defun draw-lines (stream point-seq &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream point-seq &key . #.(all-drawing-options-lambda-list :line-cap))) + (flet ((trampoline () + (if (listp point-seq) + (loop + (when (null point-seq) (return)) + (let* ((point1 (pop point-seq)) + (point2 (pop point-seq))) + (draw-line-method stream + (point-x point1) (point-y point1) + (point-x point2) (point-y point2)))) + (do ((i 0 (+ i 2))) + ((= i (length point-seq))) + (let* ((point1 (aref point-seq i)) + (point2 (aref point-seq (1+ i)))) + (draw-line-method stream + (point-x point1) (point-y point1) + (point-x point2) (point-y point2))))))) + (declare (dynamic-extent #'trampoline)) + (if args + (apply #'invoke-with-drawing-options stream #'trampoline args) + (trampoline)))) + +(defun draw-lines* (stream coord-seq &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream coord-seq &key . #.(all-drawing-options-lambda-list :line-cap))) + (flet ((trampoline () + (if (listp coord-seq) + (loop + (when (null coord-seq) (return)) + (draw-line-method stream + (pop coord-seq) (pop coord-seq) + (pop coord-seq) (pop coord-seq))) + (do ((i 0 (+ i 4))) + ((= i (length coord-seq))) + (draw-line-method stream + (aref coord-seq i) (aref coord-seq (1+ i)) + (aref coord-seq (+ i 2)) (aref coord-seq (+ i 3))))))) + (declare (dynamic-extent #'trampoline)) + (if args + (apply #'invoke-with-drawing-options stream #'trampoline args) + (trampoline)))) + +(define-graphics-operation draw-arrow (x1 y1 x2 y2 + &key (from-head nil) (to-head t) + (head-length 10) (head-width 5)) + :arguments ((point x1 y1 x2 y2)) + :drawing-options :line-cap + :method-body + (with-transformed-arguments + (let* ((dx (- x2 x1)) + (dy (- y2 y1)) + (norm (if (zerop dx) + (if (zerop dy) nil (/ 1.0 (abs dy))) + (if (zerop dy) (/ 1.0 (abs dx)) (/ (sqrt (+ (* dx dx) (* dy dy)))))))) + (when norm + (let* ((length-norm (* head-length norm)) + (ldx (* dx length-norm)) + (ldy (* dy length-norm)) + (base-norm (* head-width norm 0.5)) + (bdx (* dy base-norm)) + (bdy (* dx base-norm)) + (ink (medium-ink stream)) + (line-style (medium-line-style stream))) + (draw-line-internal stream 0 0 x1 y1 x2 y2 ink line-style) + (when from-head + (let ((xa (+ x1 ldx)) (ya (+ y1 ldy))) + (with-stack-list (points x1 y1 (+ xa bdx) (- ya bdy) (- xa bdx) (+ ya bdy)) + (draw-polygon-internal stream 0 0 points t ink nil)) + (setq x1 xa y1 ya))) + (when to-head + (let ((xa (- x2 ldx)) (ya (- y2 ldy))) + (with-stack-list (points x2 y2 (+ xa bdx) (- ya bdy) (- xa bdx) (+ ya bdy)) + (draw-polygon-internal stream 0 0 points t ink nil) + (setq x2 xa y2 ya))))))))) + +;;; More complicated. It has to decide when to call +;;; draw-rectangle-internal vs. draw-polygon-internal +(define-graphics-operation draw-rectangle (x1 y1 x2 y2 &key (filled t)) + :arguments ((point x1 y1 x2 y2)) + :drawing-options :line-joint + :method-body + (let ((transform (medium-transformation stream))) + (cond ((rectilinear-transformation-p transform) + (with-transformed-arguments + ;; "optimized" case + ;; left, top, right, bottom might not actually be those points + ;; if we've rotated by a multiple of pi. + (let ((ll (min x1 x2)) + (tt (min y1 y2)) + (rr (max x1 x2)) + (bb (max y1 y2))) + (draw-rectangle-internal stream 0 0 ll tt rr bb + (medium-ink stream) + (and (not filled) + (medium-line-style stream)))))) + (t + ;; massively inefficient + ;; --- note that "stream" and is a magic name here. + (with-stack-list (list x1 y1 x2 y1 x2 y2 x1 y2) + (draw-polygon-method stream list t filled)))))) + +(defun draw-icon* (stream icon x y &key clipping-region transformation) + (check-type icon pattern) + (let ((width (pattern-width icon)) + (height (pattern-height icon))) + (if (or clipping-region transformation) + (with-drawing-options (stream :clipping-region clipping-region + :transformation transformation)) + (draw-rectangle* stream x y (+ x width) (+ y height) + :filled t :ink icon)))) + +(defvar *float-tolerance* .00001) +(defun float-= (n1 n2) + (< (abs (- n1 n2)) *float-tolerance*)) + +(define-graphics-operation draw-ellipse (center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + &key start-angle end-angle (filled t)) + :arguments ((point center-x center-y) + (distance radius-1-dx radius-1-dy radius-2-dx radius-2-dy)) + :drawing-options :line-cap + :method-body + (with-transformed-arguments + (when (and start-angle (null end-angle)) + (setq end-angle 2pi)) + (when (and end-angle (null start-angle)) + (setq start-angle 0)) + (let ((transform (medium-transformation stream)) + (ink (medium-ink stream)) + (line-style (and (not filled) (medium-line-style stream)))) + (when start-angle + (when (reflection-transformation-p transform) + (rotatef start-angle end-angle)) + (unless (<= 0f0 (abs (- end-angle start-angle)) 2pi) + (nyi))) + (draw-ellipse-internal stream 0 0 center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle + ink line-style)))) + +(defun draw-circle (stream center radius &rest keys) + (declare (dynamic-extent keys)) + (declare (arglist stream center radius + &key start-angle end-angle (filled t) + . #.(all-drawing-options-lambda-list :line-cap))) + (apply #'draw-ellipse stream center radius 0 0 radius keys)) + +(defun draw-circle* (stream center-x center-y radius &rest keys) + (declare (dynamic-extent keys)) + (declare (arglist stream center-x center-y radius + &key start-angle end-angle (filled t) + . #.(all-drawing-options-lambda-list :line-cap))) + (apply #'draw-ellipse* stream center-x center-y radius 0 0 radius keys)) + +(define-graphics-operation draw-oval (center-x center-y x-radius y-radius + &key (filled t)) + :arguments ((point center-x center-y) + (distance x-radius y-radius)) + :drawing-options :line-cap + :method-body + (with-transformed-arguments + (let ((left (- center-x x-radius)) + (right (+ center-x x-radius)) + (top (- center-y y-radius)) + (bottom (+ center-y y-radius)) + (ink (medium-ink stream)) + (line-style (and (not filled) (medium-line-style stream)))) + (cond ((or (= x-radius y-radius) + (zerop x-radius)) + (draw-ellipse-internal stream 0 0 + center-x center-y y-radius 0 0 y-radius + nil nil ink line-style)) + ((zerop y-radius) + (draw-ellipse-internal stream 0 0 + center-x center-y x-radius 0 0 x-radius + nil nil ink line-style)) + ((> x-radius y-radius) + (let ((rect-left (+ left y-radius)) + (rect-right (- right y-radius))) + (cond (line-style + (draw-line-internal stream 0 0 + rect-left top rect-right top + ink line-style) + (draw-line-internal stream 0 0 + rect-left bottom rect-right bottom + ink line-style)) + (t + (draw-rectangle-internal stream 0 0 + rect-left top rect-right bottom + ink line-style))) + (let ((north (float (* pi 1/2) 0.0)) + (south (float (* pi 3/2) 0.0))) + (draw-ellipse-internal stream 0 0 + rect-left center-y y-radius 0 0 y-radius + north south ink line-style) + (draw-ellipse-internal stream 0 0 + rect-right center-y y-radius 0 0 y-radius + south north ink line-style)))) + (t + (let ((rect-top (+ top x-radius)) + (rect-bottom (- bottom x-radius))) + (cond (line-style + (draw-line-internal stream 0 0 + left rect-top left rect-bottom + ink line-style) + (draw-line-internal stream 0 0 + right rect-top right rect-bottom + ink line-style)) + (t + (draw-rectangle-internal stream 0 0 + left rect-top right rect-bottom + ink line-style))) + (let ((east 0.0) + (west (float pi 0.0))) + (draw-ellipse-internal stream 0 0 + center-x rect-top x-radius 0 0 x-radius + west east ink line-style) + (draw-ellipse-internal stream 0 0 + center-x rect-bottom x-radius 0 0 x-radius + east west ink line-style)))))))) + +(define-graphics-operation draw-polygon (list-of-x-and-ys &key (closed t) (filled t)) + :arguments ((point-sequence list-of-x-and-ys)) + :drawing-options :line-joint-cap + :method-body + (with-transformed-arguments + (draw-polygon-internal stream 0 0 list-of-x-and-ys closed + (medium-ink stream) + (and (not filled) (medium-line-style stream))))) + +(defun draw-regular-polygon* (stream x1 y1 x2 y2 nsides + &rest args &key (handedness :left) (closed t) &allow-other-keys) + (declare (dynamic-extent args)) + (declare (arglist stream x1 y1 x2 y2 nsides + &key (filled t) (handedness :left) (closed t) + . #.(all-drawing-options-lambda-list :line-joint-cap))) + (let* ((theta (* (float (* pi (/ 2.0 nsides)) 0.0) + (ecase handedness + (:left +1) + (:right -1)))) + (transform (make-rotation-transformation theta)) + (coordinates (list x1 y1 x2 y2)) + (dx (- x2 x1)) + (dy (- y2 y1)) + (next-x x2) + (next-y y2)) + (dotimes (i (- nsides 2)) + #-(or Allegro Minima) (declare (ignore i)) + (multiple-value-setq (dx dy) + (transform-distance transform dx dy)) + (incf next-x dx) + (incf next-y dy) + (setq coordinates (append coordinates (list next-x next-y)))) + (when closed + (setq coordinates (append coordinates (list x1 y1)))) + (with-keywords-removed (args args '(:handedness)) + (apply #'draw-polygon* stream coordinates args)))) + +(defun draw-regular-polygon (stream point1 point2 nsides &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream point1 point2 nsides + &key (handedness :left) (closed t) (filled t) + . #.(all-drawing-options-lambda-list :line-joint-cap))) + (apply #'draw-regular-polygon* stream + (point-x point1) (point-y point1) + (point-x point2) (point-y point2) + nsides args)) + +(defun draw-triangle (stream p1 p2 p3 &rest keys) + (declare (dynamic-extent keys)) + (declare (arglist stream p1 p2 p3 + &key (filled t) . #.(all-drawing-options-lambda-list :line-joint))) + (with-stack-list (points p1 p2 p3) + (apply #'draw-polygon stream points :closed t keys))) + +(defun draw-triangle* (stream x1 y1 x2 y2 x3 y3 &rest keys) + (declare (dynamic-extent keys)) + (declare (arglist stream x1 y1 x2 y2 x3 y3 + &key (filled t) . #.(all-drawing-options-lambda-list :line-joint))) + (with-stack-list (points x1 y1 x2 y2 x3 y3) + (apply #'draw-polygon* stream points :closed t keys))) + +(define-graphics-operation draw-string (string x y + &key (start 0) end + (align-x :left) ;:center, :right + (align-y :baseline));:top, :center, :bottom + :arguments ((point x y)) + :drawing-options :text + :method-body + (with-transformed-arguments + (draw-string-internal stream 0 0 + string x y start end align-x align-y + (stream-merged-text-style stream) + (medium-ink stream)))) + +(define-graphics-operation draw-character (character x y + &key (align-x :left) ;:center, :right + (align-y :baseline));:top, :center, :bottom + :arguments ((point x y)) + :drawing-options :text + :method-body + (with-transformed-arguments + (draw-character-internal stream 0 0 + character x y align-x align-y + (stream-merged-text-style stream) + (medium-ink stream)))) + +(defun draw-text (stream text point &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream text point + &key (start 0) end (align-x :left) (align-y :baseline) + . #.(all-drawing-options-lambda-list :text))) + (if (characterp text) + (apply #'draw-character stream text point args) + (apply #'draw-string stream text point args))) + +(defun draw-text* (stream text x y &rest args) + (declare (dynamic-extent args)) + (declare (arglist stream text x y + &key (start 0) end (align-x :left) (align-y :baseline) + . #.(all-drawing-options-lambda-list :text))) + (if (characterp text) + (apply #'draw-character* stream text x y args) + (apply #'draw-string* stream text x y args))) diff --git a/pre-silica/graphics-internals.lisp b/pre-silica/graphics-internals.lisp new file mode 100644 index 00000000..b847c862 --- /dev/null +++ b/pre-silica/graphics-internals.lisp @@ -0,0 +1,427 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: graphics-internals.lisp,v 1.4 91/03/26 12:48:02 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(defmacro with-half-thickness ((lthickness rthickness) line-style &body body) + (let ((thickness '#:thickness)) + `(let* ((,thickness (if ,line-style (line-style-thickness ,line-style) 0)) + (,lthickness (floor ,thickness 2)) + (,rthickness (- ,thickness ,lthickness))) + ,@body))) + +;; Note that points and paths themselves have no thickness. The stroking +;; model CLIM uses is that, when a path is stroked, the pen is centered on +;; the path, so that the thickness of the stroke is divided on both sides +;; of the path. For even-width pens, the extra ink appears on the left +;; (or below) the path. +(define-graphics-internal draw-point-internal (x y ink line-style) + :points-to-convert (x y) + :bounding-rectangle + (with-half-thickness (lthickness rthickness) line-style + (fix-rectangle (- x lthickness) (- y lthickness) + (+ x rthickness) (+ y rthickness)))) + +(defun make-design-from-output-record (record) + (multiple-value-bind (xoff yoff) (compute-output-record-offsets record) + (make-design-from-output-record-1 record xoff yoff))) + +(defmethod make-design-from-output-record-1 + ((record output-record-mixin) x-offset y-offset) + (let ((designs nil)) + (flet ((make-design (record) + (multiple-value-bind (xoff yoff) (output-record-position* record) + (declare (type coordinate xoff yoff)) + (let ((design + (make-design-from-output-record-1 + record + (+ x-offset xoff) (+ y-offset yoff)))) + (when design (push design designs)))))) + (declare (dynamic-extent #'make-design)) + (map-over-output-records #'make-design record)) + (make-instance 'composite-over :designs (apply #'vector designs)))) + +(defmethod make-design-from-output-record-1 + ((point point-displayed-output-record) x-offset y-offset) + (with-slots (x y ink) point + (compose-in + ink + (make-point (+ x x-offset) (+ y y-offset))))) + +(defgeneric draw-design (design stream &rest args) + (declare (arglist design stream &key . #.(all-drawing-options-lambda-list nil)))) + +(defmethod draw-design ((point standard-point) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (multiple-value-bind (x y) (point-position* point) + (apply #'draw-point* stream x y args))) + + +(define-graphics-internal draw-line-internal (x1 y1 x2 y2 ink line-style) + :points-to-convert (x1 y1 x2 y2) + :bounding-rectangle + (with-half-thickness (lthickness rthickness) line-style + (fix-rectangle (- (min x1 x2) lthickness) (- (min y1 y2) lthickness) + (+ (max x1 x2) rthickness) (+ (max y1 y2) rthickness))) + :highlighting-test + ((x y) + (with-slots (x1 y1 x2 y2 line-style) record + (point-close-to-line-p x y x1 y1 x2 y2 (line-style-thickness line-style)))) + :highlighting-function + ((stream state) + (declare (ignore state)) ;for now. + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent record)) + (with-slots (x1 y1 x2 y2 line-style) record + (outline-line-with-hexagon stream xoff yoff + x1 y1 x2 y2 (line-style-thickness line-style)))))) + +(defmethod make-design-from-output-record-1 + ((line line-displayed-output-record) x-offset y-offset) + (with-slots (x1 x2 y1 y2 ink) line + (compose-in + ink + (make-line* (+ x1 x-offset) (+ y1 y-offset) + (+ x2 x-offset) (+ y2 y-offset))))) + +(defmethod draw-design ((line standard-line) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (multiple-value-bind (x1 y1) (line-start-point* line) + (multiple-value-bind (x2 y2) (line-end-point* line) + (apply #'draw-line* stream x1 y1 x2 y2 args)))) + +(defun outline-line-with-hexagon (stream xoff yoff + from-x from-y to-x to-y &optional (thickness 1)) + (let ((distance (1+ (round thickness 2)))) + (multiple-value-bind (x1 y1 x2 y2 x3 y3 x4 y4 x5 y5 x6 y6) + (cond ((eq (minusp (- to-x from-x)) (minusp (- to-y from-y))) + (values (- from-x distance) (- from-y distance) + (- from-x distance) (+ from-y distance) + (- to-x distance) (+ to-y distance) + (+ to-x distance) (+ to-y distance) + (+ to-x distance) (- to-y distance) + (+ from-x distance) (- from-y distance))) + (t + (when (> to-y from-y) + ;; Make line go down to right. + (rotatef to-x from-x) + (rotatef to-y from-y)) + (values (- from-x distance) (+ from-y distance) + (- from-x distance) (- from-y distance) + (- to-x distance) (- to-y distance) + (+ to-x distance) (- to-y distance) + (+ to-x distance) (+ to-y distance) + (+ from-x distance) (+ from-y distance)))) + (macrolet ((line (x1 y1 x2 y2) + `(draw-line-internal stream xoff yoff + ,x1 ,y1 ,x2 ,y2 + +flipping-ink+ +highlighting-line-style+))) + (with-output-recording-options (stream :record nil) + (line x1 y1 x2 y2) + (line x2 y2 x3 y3) + (line x3 y3 x4 y4) + (line x4 y4 x5 y5) + (line x5 y5 x6 y6) + (line x6 y6 x1 y1)))))) + + +(define-graphics-internal draw-rectangle-internal (x1 y1 x2 y2 ink line-style) + :points-to-convert (x1 y1 x2 y2) + :bounding-rectangle + (with-half-thickness (lthickness rthickness) line-style + (fix-rectangle (- x1 lthickness) (- y1 lthickness) + (+ x2 rthickness) (+ y2 rthickness))) + :highlighting-test + ((x y) + (with-slots (x1 y1 x2 y2 line-style) record + (or (null line-style) + (with-half-thickness (lthickness rthickness) line-style + ;; Don't use LTRB-CONTAINS-POINT*-P, since that expects fixnums + ;;---- Not any more! + (not (and (<= (+ x1 rthickness) x) + (<= (+ y1 rthickness) y) + (>= (- x2 lthickness) x) + (>= (- y2 lthickness) y))))))) + :highlighting-function + ((stream state) + (declare (ignore state)) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent record)) + (with-slots (x1 y1 x2 y2 line-style) record + (with-output-recording-options (stream :record nil) + (with-half-thickness (lthickness rthickness) line-style + (draw-rectangle-internal + stream xoff yoff + (- x1 lthickness 1) (- y1 lthickness 1) + (+ x2 rthickness 1) (+ y2 rthickness 1) + +flipping-ink+ +highlighting-line-style+))))))) + +(defmethod make-design-from-output-record-1 + ((rectangle rectangle-displayed-output-record) x-offset y-offset) + (with-slots (x1 x2 y1 y2 line-style ink) rectangle + (compose-in + ink + (if (null line-style) + (make-rectangle* (+ x1 x-offset) (+ y1 y-offset) + (+ x2 x-offset) (+ y2 y-offset)) + (make-polyline* (list (+ x1 x-offset) (+ y1 y-offset) + (+ x2 x-offset) (+ y1 y-offset) + (+ x2 x-offset) (+ y2 y-offset) + (+ x1 x-offset) (+ y2 y-offset)) + :closed t))))) + +(defmethod draw-design ((rectangle standard-rectangle) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rectangle) + (apply #'draw-rectangle* stream x1 y1 x2 y2 :filled t args))) + + +;;--- This needs a :HIGHLIGHTING-TEST and :HIGHLIGHTING-FUNCTION +(define-graphics-internal draw-polygon-internal (list-of-x-and-ys closed ink line-style) + :point-sequence-to-convert list-of-x-and-ys + :bounding-rectangle + (let* ((min-x (first list-of-x-and-ys)) + (min-y (second list-of-x-and-ys)) + (max-x min-x) + (max-y min-y)) + (dorest (position list-of-x-and-ys cddr) + (minf min-x (first position)) + (minf min-y (second position)) + (maxf max-x (first position)) + (maxf max-y (second position))) + (with-half-thickness (lthickness rthickness) line-style + (fix-rectangle (- min-x lthickness) (- min-y lthickness) + (+ max-x rthickness) (+ max-y rthickness))))) + +(defmethod make-design-from-output-record-1 + ((polygon polygon-displayed-output-record) x-offset y-offset) + (with-slots (list-of-xs-and-ys closed line-style ink) polygon + (let ((coords (copy-list list-of-xs-and-ys))) + (translate-point-sequence x-offset y-offset coords) + (compose-in + ink + (if (null line-style) + (make-polygon* coords) + (make-polyline* coords :closed closed)))))) + +(defmethod draw-design ((polygon standard-polygon) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (apply #'draw-polygon stream (polygon-points polygon) :closed t :filled t args)) + +(defmethod draw-design ((polyline standard-polyline) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (with-slots (closed) polyline + (apply #'draw-polygon stream (polygon-points polyline) :closed closed :filled nil args))) + + +;; By the time we get here, START-ANGLE and END-ANGLE are either both NIL +;; or are both an angle measured in radians. +(define-graphics-internal draw-ellipse-internal + (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) + :points-to-convert (center-x center-y) + :bounding-rectangle + (multiple-value-bind (left top right bottom) + (elliptical-arc-box center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle + (and line-style (line-style-thickness line-style))) + ;;--- Make this a bit too big because most hosts rasterize + ;;--- ellipses to be a shade too big on the right + (values left top (1+ right) (1+ bottom))) + :highlighting-test + ((x y) + (with-slots (center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) record + (and (or (null start-angle) + ;; NYI - check for within the proper angle + t) + (if (null line-style) + (point-inside-ellipse-p (- x center-x) (- y center-y) + radius-1-dx radius-1-dy radius-2-dx radius-2-dy) + (point-on-thick-ellipse-p (- x center-x) (- y center-y) + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + (ceiling (line-style-thickness line-style) 2)))))) + :highlighting-function + ((stream state) + (declare (ignore state)) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent record)) + (with-slots (center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) record + (let ((delta 2) + (radius-1 (sqrt (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy)))) + (radius-2 (sqrt (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy))))) + (when line-style + (incf delta (ceiling (line-style-thickness line-style) 2))) + (let ((delta-1-dx (round (* delta radius-1-dx) radius-1)) + (delta-1-dy (round (* delta radius-1-dy) radius-1)) + (delta-2-dx (round (* delta radius-2-dx) radius-2)) + (delta-2-dy (round (* delta radius-2-dy) radius-2))) + (with-output-recording-options (stream :record nil) + (draw-ellipse-internal + stream xoff yoff + center-x center-y + (+ radius-1-dx delta-1-dx) (+ radius-1-dy delta-1-dy) + (+ radius-2-dx delta-2-dx) (+ radius-2-dy delta-2-dy) + start-angle end-angle + +flipping-ink+ +highlighting-line-style+)))))))) + +(defmethod make-design-from-output-record-1 + ((ellipse ellipse-displayed-output-record) x-offset y-offset) + (with-slots (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle line-style ink) ellipse + (compose-in + ink + (if (null line-style) + (make-ellipse* (+ center-x x-offset) (+ center-y y-offset) + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + :start-angle start-angle :end-angle end-angle) + (make-elliptical-arc* (+ center-x x-offset) (+ center-y y-offset) + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + :start-angle start-angle :end-angle end-angle))))) + +(defmethod draw-design ((ellipse standard-ellipse) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (multiple-value-bind (center-x center-y) + (ellipse-center-point* ellipse) + (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy) + (ellipse-radii ellipse) + (apply #'draw-ellipse* stream center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + :start-angle (ellipse-start-angle ellipse) + :end-angle (ellipse-end-angle ellipse) + :filled t args)))) + +(defmethod draw-design ((ellipse standard-elliptical-arc) stream &rest args &key ink line-style) + (declare (dynamic-extent args) + (ignore ink line-style)) + (multiple-value-bind (center-x center-y) + (ellipse-center-point* ellipse) + (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy) + (ellipse-radii ellipse) + (apply #'draw-ellipse* stream center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + :start-angle (ellipse-start-angle ellipse) + :end-angle (ellipse-end-angle ellipse) + :filled nil args)))) + + +(define-graphics-internal draw-string-internal + (string x y start end align-x align-y text-style ink) + :points-to-convert (x y) + ;; Don't want temporary strings to make it into the history + :output-recording-hook (setq string (evacuate-temporary-string string)) + :bounding-rectangle + ;;--- How are we allowed to call STREAM-STRING-WIDTH if this isn't + ;;--- an extended output stream?? + (let ((width (stream-string-width stream string :text-style text-style)) + (height (stream-line-height stream text-style)) + vx vt vr vb) + (declare (type coordinate width height)) + (ecase align-x + (:left (setq vx x + vr (+ x width))) + (:right (setq vx (- x width) + vr x)) + (:center (setq vx (- x (round width 2)) + vr (+ x (round width 2))))) + (ecase align-y + ;;--- Using STREAM-LINE-HEIGHT for baseline isn't right. + (:baseline (setq vt (- y height) + vb y)) + (:top (setq vt y + vb (+ y height))) + (:bottom (setq vt (- y height) + vb y)) + ;;--- Use FLOOR and CEILING, no? + (:center (setq vt (- y (round height 2)) + vb (+ y (round height 2))))) + (fix-rectangle vx vt vr vb))) + +(define-graphics-internal draw-character-internal + (character x y align-x align-y text-style ink) + :points-to-convert (x y) + ;;--- This has to deal with align-x and -y + :bounding-rectangle + ;;--- How are we allowed to call STREAM-CHARACTER-WIDTH if this isn't + ;;--- an extended output stream? + (multiple-value-bind (width height) + (stream-character-size stream character text-style) + (declare (type coordinate width height)) + (let (vx vt vr vb) + (ecase align-x + (:left (setq vx x + vr (+ x width))) + (:right (setq vx (- x width) + vr x)) + (:center (setq vx (- x (round width 2)) + vr (+ x (round width 2))))) + (ecase align-y + (:baseline (setq vt (- y height) + vb y)) + (:top (setq vt y + vb (+ y height))) + (:bottom (setq vt (- y height) + vb y)) + ;;--- Use FLOOR and CEILING, no? + (:center (setq vt (- y (round height 2)) + vb (+ y (round height 2))))) + (fix-rectangle vx vt vr vb)))) + + +;;; Simple rendering of composite designs + +(defmethod draw-design ((composite composite-over) stream &rest args) + (declare (dynamic-extent args)) + (with-slots ((designs clim-utils::designs)) composite + (dovector (design designs :from-end t) + (apply #'draw-design design stream args)))) + +(defmethod draw-design ((composite composite-in) stream &rest args &key ink &allow-other-keys) + (declare (dynamic-extent args)) + (with-slots ((designs clim-utils::designs)) composite + (let ((ink (or ink (aref designs 0))) ;should be COMPOSE-OVER + (design (aref designs 1))) + ;; Clips INK to the inside of DESIGN. + (apply #'draw-design design stream :ink ink args)))) + +(defmethod draw-design ((composite composite-out) stream &rest args &key ink &allow-other-keys) + (declare (dynamic-extent args)) + (with-slots ((designs clim-utils::designs)) composite + (let ((ink (or ink (aref designs 0))) ;should be COMPOSE-OVER + (design (aref designs 1))) + ;;--- Should clip INK to the outside of DESIGN, but I don't know how + (nyi)))) + +(defmethod draw-design ((region standard-region-union) stream &rest args) + (declare (dynamic-extent args)) + (with-slots ((regions clim-utils::regions)) region + (dolist (region regions) + (apply #'draw-design region stream args)))) + +(defmethod draw-design ((region standard-region-intersection) stream &rest args) + (declare (dynamic-extent args)) + (with-slots ((regions clim-utils::regions)) region + ;;--- Should draw just the intersection, but I dunno how to do that in general + (nyi))) + +(defmethod draw-design ((region standard-region-difference) stream &rest args) + (declare (dynamic-extent args)) + (with-slots ((region1 clim-utils::region1) + (region2 clim-utils::region2)) region + ;;--- Should draw just the difference, but I dunno how to do that in general + (nyi))) diff --git a/pre-silica/laserwriter-metrics.lisp b/pre-silica/laserwriter-metrics.lisp new file mode 100644 index 00000000..40c543d3 --- /dev/null +++ b/pre-silica/laserwriter-metrics.lisp @@ -0,0 +1,2145 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: laserwriter-metrics.lisp,v 1.4 91/03/26 12:48:11 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; Font Metrics for Apple Laser Writer builtin fonts + +;;; Note that the X values in the bounding box are incorrect. I don't +;;; know how this data was generated (it was inherited from the Genera +;;; LGP2 support) but it is apparent that the font box information +;;; (/FontBBox element of a PostScript fnt dictionary) was not scaled by +;;; the font's matrix (/FontMatrix). For the fonts that I tested (using +;;; the PostScript program at the end of this file), the Y values were +;;; correct but some of the X values were not. Fortunately nothing uses +;;; them. [1/9/90 naha] + +(setup-laserwriter-metrics + '(("Times-Roman" 1000 (-167 -252 1004 904)) + (#o040 250.0 "space") + (#o041 333.0 "exclam") + (#o042 408.0 "quotedbl") + (#o043 500.0 "numbersign") + (#o044 500.0 "dollar") + (#o045 833.0 "percent") + (#o046 778.0 "ampersand") + (#o047 333.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 500.0 "asterisk") + (#o053 564.0 "plus") + (#o054 250.0 "comma") + (#o055 333.0 "hyphen") + (#o056 250.0 "period") + (#o057 278.0 "slash") + (#o060 500.0 "zero") + (#o061 500.0 "one") + (#o062 500.0 "two") + (#o063 500.0 "three") + (#o064 500.0 "four") + (#o065 500.0 "five") + (#o066 500.0 "six") + (#o067 500.0 "seven") + (#o070 500.0 "eight") + (#o071 500.0 "nine") + (#o072 278.0 "colon") + (#o073 278.0 "semicolon") + (#o074 564.0 "less") + (#o075 564.0 "equal") + (#o076 564.0 "greater") + (#o077 444.0 "question") + (#o100 921.0 "at") + (#o101 722.0 "A") + (#o102 667.0 "B") + (#o103 667.0 "C") + (#o104 722.0 "D") + (#o105 611.0 "E") + (#o106 556.0 "F") + (#o107 722.0 "G") + (#o110 722.0 "H") + (#o111 333.0 "I") + (#o112 389.0 "J") + (#o113 722.0 "K") + (#o114 611.0 "L") + (#o115 889.0 "M") + (#o116 722.0 "N") + (#o117 722.0 "O") + (#o120 556.0 "P") + (#o121 722.0 "Q") + (#o122 667.0 "R") + (#o123 556.0 "S") + (#o124 611.0 "T") + (#o125 722.0 "U") + (#o126 722.0 "V") + (#o127 944.0 "W") + (#o130 722.0 "X") + (#o131 722.0 "Y") + (#o132 611.0 "Z") + (#o133 333.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 333.0 "bracketright") + (#o136 469.0 "asciicircum") + (#o137 500.0 "underscore") + (#o140 333.0 "quoteleft") + (#o141 444.0 "a") + (#o142 500.0 "b") + (#o143 444.0 "c") + (#o144 500.0 "d") + (#o145 444.0 "e") + (#o146 333.0 "f") + (#o147 500.0 "g") + (#o150 500.0 "h") + (#o151 278.0 "i") + (#o152 278.0 "j") + (#o153 500.0 "k") + (#o154 278.0 "l") + (#o155 778.0 "m") + (#o156 500.0 "n") + (#o157 500.0 "o") + (#o160 500.0 "p") + (#o161 500.0 "q") + (#o162 333.0 "r") + (#o163 389.0 "s") + (#o164 278.0 "t") + (#o165 500.0 "u") + (#o166 500.0 "v") + (#o167 722.0 "w") + (#o170 500.0 "x") + (#o171 500.0 "y") + (#o172 444.0 "z") + (#o173 480.0 "braceleft") + (#o174 200.0 "bar") + (#o175 480.0 "braceright") + (#o176 541.0 "asciitilde") + (#o241 333.0 "exclamdown") + (#o242 500.0 "cent") + (#o243 500.0 "sterling") + (#o244 167.0 "fraction") + (#o245 500.0 "yen") + (#o246 500.0 "florin") + (#o247 500.0 "section") + (#o250 500.0 "currency") + (#o251 180.0 "quotesingle") + (#o252 444.0 "quotedblleft") + (#o253 500.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 556.0 "fi") + (#o257 556.0 "fl") + (#o261 500.0 "endash") + (#o262 500.0 "dagger") + (#o263 500.0 "daggerdbl") + (#o264 250.0 "periodcentered") + (#o266 453.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 333.0 "quotesinglbase") + (#o271 444.0 "quotedblbase") + (#o272 444.0 "quotedblright") + (#o273 500.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 444.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 889.0 "AE") + (#o343 276.0 "ordfeminine") + (#o350 611.0 "Lslash") + (#o351 722.0 "Oslash") + (#o352 889.0 "OE") + (#o353 310.0 "ordmasculine") + (#o361 667.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 278.0 "lslash") + (#o371 500.0 "oslash") + (#o372 722.0 "oe") + (#o373 500.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Times-Italic" 1000 (-176 -252 998 930)) + (#o040 250.0 "space") + (#o041 333.0 "exclam") + (#o042 420.0 "quotedbl") + (#o043 500.0 "numbersign") + (#o044 500.0 "dollar") + (#o045 833.0 "percent") + (#o046 778.0 "ampersand") + (#o047 333.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 500.0 "asterisk") + (#o053 675.0 "plus") + (#o054 250.0 "comma") + (#o055 333.0 "hyphen") + (#o056 250.0 "period") + (#o057 278.0 "slash") + (#o060 500.0 "zero") + (#o061 500.0 "one") + (#o062 500.0 "two") + (#o063 500.0 "three") + (#o064 500.0 "four") + (#o065 500.0 "five") + (#o066 500.0 "six") + (#o067 500.0 "seven") + (#o070 500.0 "eight") + (#o071 500.0 "nine") + (#o072 333.0 "colon") + (#o073 333.0 "semicolon") + (#o074 675.0 "less") + (#o075 675.0 "equal") + (#o076 675.0 "greater") + (#o077 500.0 "question") + (#o100 920.0 "at") + (#o101 611.0 "A") + (#o102 611.0 "B") + (#o103 667.0 "C") + (#o104 722.0 "D") + (#o105 611.0 "E") + (#o106 611.0 "F") + (#o107 722.0 "G") + (#o110 722.0 "H") + (#o111 333.0 "I") + (#o112 444.0 "J") + (#o113 667.0 "K") + (#o114 556.0 "L") + (#o115 833.0 "M") + (#o116 667.0 "N") + (#o117 722.0 "O") + (#o120 611.0 "P") + (#o121 722.0 "Q") + (#o122 611.0 "R") + (#o123 500.0 "S") + (#o124 556.0 "T") + (#o125 722.0 "U") + (#o126 611.0 "V") + (#o127 833.0 "W") + (#o130 611.0 "X") + (#o131 556.0 "Y") + (#o132 556.0 "Z") + (#o133 389.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 389.0 "bracketright") + (#o136 422.0 "asciicircum") + (#o137 500.0 "underscore") + (#o140 333.0 "quoteleft") + (#o141 500.0 "a") + (#o142 500.0 "b") + (#o143 444.0 "c") + (#o144 500.0 "d") + (#o145 444.0 "e") + (#o146 278.0 "f") + (#o147 500.0 "g") + (#o150 500.0 "h") + (#o151 278.0 "i") + (#o152 278.0 "j") + (#o153 444.0 "k") + (#o154 278.0 "l") + (#o155 722.0 "m") + (#o156 500.0 "n") + (#o157 500.0 "o") + (#o160 500.0 "p") + (#o161 500.0 "q") + (#o162 389.0 "r") + (#o163 389.0 "s") + (#o164 278.0 "t") + (#o165 500.0 "u") + (#o166 444.0 "v") + (#o167 667.0 "w") + (#o170 444.0 "x") + (#o171 444.0 "y") + (#o172 389.0 "z") + (#o173 400.0 "braceleft") + (#o174 275.0 "bar") + (#o175 400.0 "braceright") + (#o176 541.0 "asciitilde") + (#o241 389.0 "exclamdown") + (#o242 500.0 "cent") + (#o243 500.0 "sterling") + (#o244 167.0 "fraction") + (#o245 500.0 "yen") + (#o246 500.0 "florin") + (#o247 500.0 "section") + (#o250 500.0 "currency") + (#o251 214.0 "quotesingle") + (#o252 556.0 "quotedblleft") + (#o253 500.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 500.0 "fi") + (#o257 500.0 "fl") + (#o261 500.0 "endash") + (#o262 500.0 "dagger") + (#o263 500.0 "daggerdbl") + (#o264 250.0 "periodcentered") + (#o266 523.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 333.0 "quotesinglbase") + (#o271 556.0 "quotedblbase") + (#o272 556.0 "quotedblright") + (#o273 500.0 "guillemotright") + (#o274 889.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 500.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 889.0 "emdash") + (#o341 889.0 "AE") + (#o343 276.0 "ordfeminine") + (#o350 556.0 "Lslash") + (#o351 722.0 "Oslash") + (#o352 944.0 "OE") + (#o353 310.0 "ordmasculine") + (#o361 667.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 278.0 "lslash") + (#o371 500.0 "oslash") + (#o372 667.0 "oe") + (#o373 500.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Times-Bold" 1000 (-172 -257 1008 965)) + (#o040 250.0 "space") + (#o041 333.0 "exclam") + (#o042 555.0 "quotedbl") + (#o043 500.0 "numbersign") + (#o044 500.0 "dollar") + (#o045 1000.0 "percent") + (#o046 833.0 "ampersand") + (#o047 333.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 500.0 "asterisk") + (#o053 570.0 "plus") + (#o054 250.0 "comma") + (#o055 333.0 "hyphen") + (#o056 250.0 "period") + (#o057 278.0 "slash") + (#o060 500.0 "zero") + (#o061 500.0 "one") + (#o062 500.0 "two") + (#o063 500.0 "three") + (#o064 500.0 "four") + (#o065 500.0 "five") + (#o066 500.0 "six") + (#o067 500.0 "seven") + (#o070 500.0 "eight") + (#o071 500.0 "nine") + (#o072 333.0 "colon") + (#o073 333.0 "semicolon") + (#o074 570.0 "less") + (#o075 570.0 "equal") + (#o076 570.0 "greater") + (#o077 500.0 "question") + (#o100 930.0 "at") + (#o101 722.0 "A") + (#o102 667.0 "B") + (#o103 722.0 "C") + (#o104 722.0 "D") + (#o105 667.0 "E") + (#o106 611.0 "F") + (#o107 778.0 "G") + (#o110 778.0 "H") + (#o111 389.0 "I") + (#o112 500.0 "J") + (#o113 778.0 "K") + (#o114 667.0 "L") + (#o115 944.0 "M") + (#o116 722.0 "N") + (#o117 778.0 "O") + (#o120 611.0 "P") + (#o121 778.0 "Q") + (#o122 722.0 "R") + (#o123 556.0 "S") + (#o124 667.0 "T") + (#o125 722.0 "U") + (#o126 722.0 "V") + (#o127 1000.0 "W") + (#o130 722.0 "X") + (#o131 722.0 "Y") + (#o132 667.0 "Z") + (#o133 333.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 333.0 "bracketright") + (#o136 581.0 "asciicircum") + (#o137 500.0 "underscore") + (#o140 333.0 "quoteleft") + (#o141 500.0 "a") + (#o142 556.0 "b") + (#o143 444.0 "c") + (#o144 556.0 "d") + (#o145 444.0 "e") + (#o146 333.0 "f") + (#o147 500.0 "g") + (#o150 556.0 "h") + (#o151 278.0 "i") + (#o152 333.0 "j") + (#o153 556.0 "k") + (#o154 278.0 "l") + (#o155 833.0 "m") + (#o156 556.0 "n") + (#o157 500.0 "o") + (#o160 556.0 "p") + (#o161 556.0 "q") + (#o162 444.0 "r") + (#o163 389.0 "s") + (#o164 333.0 "t") + (#o165 556.0 "u") + (#o166 500.0 "v") + (#o167 722.0 "w") + (#o170 500.0 "x") + (#o171 500.0 "y") + (#o172 444.0 "z") + (#o173 394.0 "braceleft") + (#o174 220.0 "bar") + (#o175 394.0 "braceright") + (#o176 520.0 "asciitilde") + (#o241 333.0 "exclamdown") + (#o242 500.0 "cent") + (#o243 500.0 "sterling") + (#o244 167.0 "fraction") + (#o245 500.0 "yen") + (#o246 500.0 "florin") + (#o247 500.0 "section") + (#o250 500.0 "currency") + (#o251 278.0 "quotesingle") + (#o252 500.0 "quotedblleft") + (#o253 500.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 556.0 "fi") + (#o257 556.0 "fl") + (#o261 500.0 "endash") + (#o262 500.0 "dagger") + (#o263 500.0 "daggerdbl") + (#o264 250.0 "periodcentered") + (#o266 540.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 333.0 "quotesinglbase") + (#o271 500.0 "quotedblbase") + (#o272 500.0 "quotedblright") + (#o273 500.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 500.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 1000.0 "AE") + (#o343 300.0 "ordfeminine") + (#o350 667.0 "Lslash") + (#o351 778.0 "Oslash") + (#o352 1000.0 "OE") + (#o353 330.0 "ordmasculine") + (#o361 722.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 278.0 "lslash") + (#o371 500.0 "oslash") + (#o372 722.0 "oe") + (#o373 556.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Times-BoldItalic" 1000 (-183 -250 1004 973)) + (#o040 250.0 "space") + (#o041 389.0 "exclam") + (#o042 555.0 "quotedbl") + (#o043 500.0 "numbersign") + (#o044 500.0 "dollar") + (#o045 833.0 "percent") + (#o046 778.0 "ampersand") + (#o047 333.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 500.0 "asterisk") + (#o053 570.0 "plus") + (#o054 250.0 "comma") + (#o055 333.0 "hyphen") + (#o056 250.0 "period") + (#o057 278.0 "slash") + (#o060 500.0 "zero") + (#o061 500.0 "one") + (#o062 500.0 "two") + (#o063 500.0 "three") + (#o064 500.0 "four") + (#o065 500.0 "five") + (#o066 500.0 "six") + (#o067 500.0 "seven") + (#o070 500.0 "eight") + (#o071 500.0 "nine") + (#o072 333.0 "colon") + (#o073 333.0 "semicolon") + (#o074 570.0 "less") + (#o075 570.0 "equal") + (#o076 570.0 "greater") + (#o077 500.0 "question") + (#o100 832.0 "at") + (#o101 667.0 "A") + (#o102 667.0 "B") + (#o103 667.0 "C") + (#o104 722.0 "D") + (#o105 667.0 "E") + (#o106 667.0 "F") + (#o107 722.0 "G") + (#o110 778.0 "H") + (#o111 389.0 "I") + (#o112 500.0 "J") + (#o113 667.0 "K") + (#o114 611.0 "L") + (#o115 889.0 "M") + (#o116 722.0 "N") + (#o117 722.0 "O") + (#o120 611.0 "P") + (#o121 722.0 "Q") + (#o122 667.0 "R") + (#o123 556.0 "S") + (#o124 611.0 "T") + (#o125 722.0 "U") + (#o126 667.0 "V") + (#o127 889.0 "W") + (#o130 667.0 "X") + (#o131 611.0 "Y") + (#o132 611.0 "Z") + (#o133 333.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 333.0 "bracketright") + (#o136 570.0 "asciicircum") + (#o137 500.0 "underscore") + (#o140 333.0 "quoteleft") + (#o141 500.0 "a") + (#o142 500.0 "b") + (#o143 444.0 "c") + (#o144 500.0 "d") + (#o145 444.0 "e") + (#o146 333.0 "f") + (#o147 500.0 "g") + (#o150 556.0 "h") + (#o151 278.0 "i") + (#o152 278.0 "j") + (#o153 500.0 "k") + (#o154 278.0 "l") + (#o155 778.0 "m") + (#o156 556.0 "n") + (#o157 500.0 "o") + (#o160 500.0 "p") + (#o161 500.0 "q") + (#o162 389.0 "r") + (#o163 389.0 "s") + (#o164 278.0 "t") + (#o165 556.0 "u") + (#o166 444.0 "v") + (#o167 667.0 "w") + (#o170 500.0 "x") + (#o171 444.0 "y") + (#o172 389.0 "z") + (#o173 348.0 "braceleft") + (#o174 220.0 "bar") + (#o175 348.0 "braceright") + (#o176 570.0 "asciitilde") + (#o241 389.0 "exclamdown") + (#o242 500.0 "cent") + (#o243 500.0 "sterling") + (#o244 167.0 "fraction") + (#o245 500.0 "yen") + (#o246 500.0 "florin") + (#o247 500.0 "section") + (#o250 500.0 "currency") + (#o251 278.0 "quotesingle") + (#o252 500.0 "quotedblleft") + (#o253 500.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 556.0 "fi") + (#o257 556.0 "fl") + (#o261 500.0 "endash") + (#o262 500.0 "dagger") + (#o263 500.0 "daggerdbl") + (#o264 250.0 "periodcentered") + (#o266 500.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 333.0 "quotesinglbase") + (#o271 500.0 "quotedblbase") + (#o272 500.0 "quotedblright") + (#o273 500.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 500.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 944.0 "AE") + (#o343 266.0 "ordfeminine") + (#o350 611.0 "Lslash") + (#o351 722.0 "Oslash") + (#o352 944.0 "OE") + (#o353 300.0 "ordmasculine") + (#o361 722.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 278.0 "lslash") + (#o371 500.0 "oslash") + (#o372 722.0 "oe") + (#o373 500.0 "germandbls") + )) + + +(setup-laserwriter-metrics + '(("Helvetica" 1000 (-174 -234 1001 941)) + (#o040 278.0 "space") + (#o041 278.0 "exclam") + (#o042 355.0 "quotedbl") + (#o043 556.0 "numbersign") + (#o044 556.0 "dollar") + (#o045 889.0 "percent") + (#o046 667.0 "ampersand") + (#o047 222.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 389.0 "asterisk") + (#o053 584.0 "plus") + (#o054 278.0 "comma") + (#o055 333.0 "hyphen") + (#o056 278.0 "period") + (#o057 278.0 "slash") + (#o060 556.0 "zero") + (#o061 556.0 "one") + (#o062 556.0 "two") + (#o063 556.0 "three") + (#o064 556.0 "four") + (#o065 556.0 "five") + (#o066 556.0 "six") + (#o067 556.0 "seven") + (#o070 556.0 "eight") + (#o071 556.0 "nine") + (#o072 278.0 "colon") + (#o073 278.0 "semicolon") + (#o074 584.0 "less") + (#o075 584.0 "equal") + (#o076 584.0 "greater") + (#o077 556.0 "question") + (#o100 1015.0 "at") + (#o101 667.0 "A") + (#o102 667.0 "B") + (#o103 722.0 "C") + (#o104 722.0 "D") + (#o105 667.0 "E") + (#o106 611.0 "F") + (#o107 778.0 "G") + (#o110 722.0 "H") + (#o111 278.0 "I") + (#o112 500.0 "J") + (#o113 667.0 "K") + (#o114 556.0 "L") + (#o115 833.0 "M") + (#o116 722.0 "N") + (#o117 778.0 "O") + (#o120 667.0 "P") + (#o121 778.0 "Q") + (#o122 722.0 "R") + (#o123 667.0 "S") + (#o124 611.0 "T") + (#o125 722.0 "U") + (#o126 667.0 "V") + (#o127 944.0 "W") + (#o130 667.0 "X") + (#o131 667.0 "Y") + (#o132 611.0 "Z") + (#o133 278.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 278.0 "bracketright") + (#o136 469.0 "asciicircum") + (#o137 556.0 "underscore") + (#o140 222.0 "quoteleft") + (#o141 556.0 "a") + (#o142 556.0 "b") + (#o143 500.0 "c") + (#o144 556.0 "d") + (#o145 556.0 "e") + (#o146 278.0 "f") + (#o147 556.0 "g") + (#o150 556.0 "h") + (#o151 222.0 "i") + (#o152 222.0 "j") + (#o153 500.0 "k") + (#o154 222.0 "l") + (#o155 833.0 "m") + (#o156 556.0 "n") + (#o157 556.0 "o") + (#o160 556.0 "p") + (#o161 556.0 "q") + (#o162 333.0 "r") + (#o163 500.0 "s") + (#o164 278.0 "t") + (#o165 556.0 "u") + (#o166 500.0 "v") + (#o167 722.0 "w") + (#o170 500.0 "x") + (#o171 500.0 "y") + (#o172 500.0 "z") + (#o173 334.0 "braceleft") + (#o174 260.0 "bar") + (#o175 334.0 "braceright") + (#o176 584.0 "asciitilde") + (#o241 333.0 "exclamdown") + (#o242 556.0 "cent") + (#o243 556.0 "sterling") + (#o244 167.0 "fraction") + (#o245 556.0 "yen") + (#o246 556.0 "florin") + (#o247 556.0 "section") + (#o250 556.0 "currency") + (#o251 191.0 "quotesingle") + (#o252 333.0 "quotedblleft") + (#o253 556.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 500.0 "fi") + (#o257 500.0 "fl") + (#o261 556.0 "endash") + (#o262 556.0 "dagger") + (#o263 556.0 "daggerdbl") + (#o264 278.0 "periodcentered") + (#o266 537.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 222.0 "quotesinglbase") + (#o271 333.0 "quotedblbase") + (#o272 333.0 "quotedblright") + (#o273 556.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 611.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 1000.0 "AE") + (#o343 370.0 "ordfeminine") + (#o350 556.0 "Lslash") + (#o351 778.0 "Oslash") + (#o352 1000.0 "OE") + (#o353 365.0 "ordmasculine") + (#o361 889.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 222.0 "lslash") + (#o371 611.0 "oslash") + (#o372 944.0 "oe") + (#o373 611.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Helvetica-Oblique" 1000 (-174 -234 1001 941)) + (#o040 278.0 "space") + (#o041 278.0 "exclam") + (#o042 355.0 "quotedbl") + (#o043 556.0 "numbersign") + (#o044 556.0 "dollar") + (#o045 889.0 "percent") + (#o046 667.0 "ampersand") + (#o047 222.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 389.0 "asterisk") + (#o053 584.0 "plus") + (#o054 278.0 "comma") + (#o055 333.0 "hyphen") + (#o056 278.0 "period") + (#o057 278.0 "slash") + (#o060 556.0 "zero") + (#o061 556.0 "one") + (#o062 556.0 "two") + (#o063 556.0 "three") + (#o064 556.0 "four") + (#o065 556.0 "five") + (#o066 556.0 "six") + (#o067 556.0 "seven") + (#o070 556.0 "eight") + (#o071 556.0 "nine") + (#o072 278.0 "colon") + (#o073 278.0 "semicolon") + (#o074 584.0 "less") + (#o075 584.0 "equal") + (#o076 584.0 "greater") + (#o077 556.0 "question") + (#o100 1015.0 "at") + (#o101 667.0 "A") + (#o102 667.0 "B") + (#o103 722.0 "C") + (#o104 722.0 "D") + (#o105 667.0 "E") + (#o106 611.0 "F") + (#o107 778.0 "G") + (#o110 722.0 "H") + (#o111 278.0 "I") + (#o112 500.0 "J") + (#o113 667.0 "K") + (#o114 556.0 "L") + (#o115 833.0 "M") + (#o116 722.0 "N") + (#o117 778.0 "O") + (#o120 667.0 "P") + (#o121 778.0 "Q") + (#o122 722.0 "R") + (#o123 667.0 "S") + (#o124 611.0 "T") + (#o125 722.0 "U") + (#o126 667.0 "V") + (#o127 944.0 "W") + (#o130 667.0 "X") + (#o131 667.0 "Y") + (#o132 611.0 "Z") + (#o133 278.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 278.0 "bracketright") + (#o136 469.0 "asciicircum") + (#o137 556.0 "underscore") + (#o140 222.0 "quoteleft") + (#o141 556.0 "a") + (#o142 556.0 "b") + (#o143 500.0 "c") + (#o144 556.0 "d") + (#o145 556.0 "e") + (#o146 278.0 "f") + (#o147 556.0 "g") + (#o150 556.0 "h") + (#o151 222.0 "i") + (#o152 222.0 "j") + (#o153 500.0 "k") + (#o154 222.0 "l") + (#o155 833.0 "m") + (#o156 556.0 "n") + (#o157 556.0 "o") + (#o160 556.0 "p") + (#o161 556.0 "q") + (#o162 333.0 "r") + (#o163 500.0 "s") + (#o164 278.0 "t") + (#o165 556.0 "u") + (#o166 500.0 "v") + (#o167 722.0 "w") + (#o170 500.0 "x") + (#o171 500.0 "y") + (#o172 500.0 "z") + (#o173 334.0 "braceleft") + (#o174 260.0 "bar") + (#o175 334.0 "braceright") + (#o176 584.0 "asciitilde") + (#o241 333.0 "exclamdown") + (#o242 556.0 "cent") + (#o243 556.0 "sterling") + (#o244 167.0 "fraction") + (#o245 556.0 "yen") + (#o246 556.0 "florin") + (#o247 556.0 "section") + (#o250 556.0 "currency") + (#o251 191.0 "quotesingle") + (#o252 333.0 "quotedblleft") + (#o253 556.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 500.0 "fi") + (#o257 500.0 "fl") + (#o261 556.0 "endash") + (#o262 556.0 "dagger") + (#o263 556.0 "daggerdbl") + (#o264 278.0 "periodcentered") + (#o266 537.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 222.0 "quotesinglbase") + (#o271 333.0 "quotedblbase") + (#o272 333.0 "quotedblright") + (#o273 556.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 611.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 1000.0 "AE") + (#o343 370.0 "ordfeminine") + (#o350 556.0 "Lslash") + (#o351 778.0 "Oslash") + (#o352 1000.0 "OE") + (#o353 365.0 "ordmasculine") + (#o361 889.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 222.0 "lslash") + (#o371 611.0 "oslash") + (#o372 944.0 "oe") + (#o373 611.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Helvetica-Bold" 1000 (-173 -241 1003 936)) + (#o040 278.0 "space") + (#o041 333.0 "exclam") + (#o042 474.0 "quotedbl") + (#o043 556.0 "numbersign") + (#o044 556.0 "dollar") + (#o045 889.0 "percent") + (#o046 722.0 "ampersand") + (#o047 278.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 389.0 "asterisk") + (#o053 584.0 "plus") + (#o054 278.0 "comma") + (#o055 333.0 "hyphen") + (#o056 278.0 "period") + (#o057 278.0 "slash") + (#o060 556.0 "zero") + (#o061 556.0 "one") + (#o062 556.0 "two") + (#o063 556.0 "three") + (#o064 556.0 "four") + (#o065 556.0 "five") + (#o066 556.0 "six") + (#o067 556.0 "seven") + (#o070 556.0 "eight") + (#o071 556.0 "nine") + (#o072 333.0 "colon") + (#o073 333.0 "semicolon") + (#o074 584.0 "less") + (#o075 584.0 "equal") + (#o076 584.0 "greater") + (#o077 611.0 "question") + (#o100 975.0 "at") + (#o101 722.0 "A") + (#o102 722.0 "B") + (#o103 722.0 "C") + (#o104 722.0 "D") + (#o105 667.0 "E") + (#o106 611.0 "F") + (#o107 778.0 "G") + (#o110 722.0 "H") + (#o111 278.0 "I") + (#o112 556.0 "J") + (#o113 722.0 "K") + (#o114 611.0 "L") + (#o115 833.0 "M") + (#o116 722.0 "N") + (#o117 778.0 "O") + (#o120 667.0 "P") + (#o121 778.0 "Q") + (#o122 722.0 "R") + (#o123 667.0 "S") + (#o124 611.0 "T") + (#o125 722.0 "U") + (#o126 667.0 "V") + (#o127 944.0 "W") + (#o130 667.0 "X") + (#o131 667.0 "Y") + (#o132 611.0 "Z") + (#o133 333.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 333.0 "bracketright") + (#o136 584.0 "asciicircum") + (#o137 556.0 "underscore") + (#o140 278.0 "quoteleft") + (#o141 556.0 "a") + (#o142 611.0 "b") + (#o143 556.0 "c") + (#o144 611.0 "d") + (#o145 556.0 "e") + (#o146 333.0 "f") + (#o147 611.0 "g") + (#o150 611.0 "h") + (#o151 278.0 "i") + (#o152 278.0 "j") + (#o153 556.0 "k") + (#o154 278.0 "l") + (#o155 889.0 "m") + (#o156 611.0 "n") + (#o157 611.0 "o") + (#o160 611.0 "p") + (#o161 611.0 "q") + (#o162 389.0 "r") + (#o163 556.0 "s") + (#o164 333.0 "t") + (#o165 611.0 "u") + (#o166 556.0 "v") + (#o167 778.0 "w") + (#o170 556.0 "x") + (#o171 556.0 "y") + (#o172 500.0 "z") + (#o173 389.0 "braceleft") + (#o174 280.0 "bar") + (#o175 389.0 "braceright") + (#o176 584.0 "asciitilde") + (#o241 333.0 "exclamdown") + (#o242 556.0 "cent") + (#o243 556.0 "sterling") + (#o244 167.0 "fraction") + (#o245 556.0 "yen") + (#o246 556.0 "florin") + (#o247 556.0 "section") + (#o250 556.0 "currency") + (#o251 238.0 "quotesingle") + (#o252 500.0 "quotedblleft") + (#o253 556.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 611.0 "fi") + (#o257 611.0 "fl") + (#o261 556.0 "endash") + (#o262 556.0 "dagger") + (#o263 556.0 "daggerdbl") + (#o264 278.0 "periodcentered") + (#o266 556.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 278.0 "quotesinglbase") + (#o271 500.0 "quotedblbase") + (#o272 500.0 "quotedblright") + (#o273 556.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 611.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 1000.0 "AE") + (#o343 370.0 "ordfeminine") + (#o350 611.0 "Lslash") + (#o351 778.0 "Oslash") + (#o352 1000.0 "OE") + (#o353 365.0 "ordmasculine") + (#o361 889.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 278.0 "lslash") + (#o371 611.0 "oslash") + (#o372 944.0 "oe") + (#o373 611.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Helvetica-BoldOblique" 1000 (-173 -241 1003 936)) + (#o040 278.0 "space") + (#o041 333.0 "exclam") + (#o042 474.0 "quotedbl") + (#o043 556.0 "numbersign") + (#o044 556.0 "dollar") + (#o045 889.0 "percent") + (#o046 722.0 "ampersand") + (#o047 278.0 "quoteright") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 389.0 "asterisk") + (#o053 584.0 "plus") + (#o054 278.0 "comma") + (#o055 333.0 "hyphen") + (#o056 278.0 "period") + (#o057 278.0 "slash") + (#o060 556.0 "zero") + (#o061 556.0 "one") + (#o062 556.0 "two") + (#o063 556.0 "three") + (#o064 556.0 "four") + (#o065 556.0 "five") + (#o066 556.0 "six") + (#o067 556.0 "seven") + (#o070 556.0 "eight") + (#o071 556.0 "nine") + (#o072 333.0 "colon") + (#o073 333.0 "semicolon") + (#o074 584.0 "less") + (#o075 584.0 "equal") + (#o076 584.0 "greater") + (#o077 611.0 "question") + (#o100 975.0 "at") + (#o101 722.0 "A") + (#o102 722.0 "B") + (#o103 722.0 "C") + (#o104 722.0 "D") + (#o105 667.0 "E") + (#o106 611.0 "F") + (#o107 778.0 "G") + (#o110 722.0 "H") + (#o111 278.0 "I") + (#o112 556.0 "J") + (#o113 722.0 "K") + (#o114 611.0 "L") + (#o115 833.0 "M") + (#o116 722.0 "N") + (#o117 778.0 "O") + (#o120 667.0 "P") + (#o121 778.0 "Q") + (#o122 722.0 "R") + (#o123 667.0 "S") + (#o124 611.0 "T") + (#o125 722.0 "U") + (#o126 667.0 "V") + (#o127 944.0 "W") + (#o130 667.0 "X") + (#o131 667.0 "Y") + (#o132 611.0 "Z") + (#o133 333.0 "bracketleft") + (#o134 278.0 "backslash") + (#o135 333.0 "bracketright") + (#o136 584.0 "asciicircum") + (#o137 556.0 "underscore") + (#o140 278.0 "quoteleft") + (#o141 556.0 "a") + (#o142 611.0 "b") + (#o143 556.0 "c") + (#o144 611.0 "d") + (#o145 556.0 "e") + (#o146 333.0 "f") + (#o147 611.0 "g") + (#o150 611.0 "h") + (#o151 278.0 "i") + (#o152 278.0 "j") + (#o153 556.0 "k") + (#o154 278.0 "l") + (#o155 889.0 "m") + (#o156 611.0 "n") + (#o157 611.0 "o") + (#o160 611.0 "p") + (#o161 611.0 "q") + (#o162 389.0 "r") + (#o163 556.0 "s") + (#o164 333.0 "t") + (#o165 611.0 "u") + (#o166 556.0 "v") + (#o167 778.0 "w") + (#o170 556.0 "x") + (#o171 556.0 "y") + (#o172 500.0 "z") + (#o173 389.0 "braceleft") + (#o174 280.0 "bar") + (#o175 389.0 "braceright") + (#o176 584.0 "asciitilde") + (#o241 333.0 "exclamdown") + (#o242 556.0 "cent") + (#o243 556.0 "sterling") + (#o244 167.0 "fraction") + (#o245 556.0 "yen") + (#o246 556.0 "florin") + (#o247 556.0 "section") + (#o250 556.0 "currency") + (#o251 238.0 "quotesingle") + (#o252 500.0 "quotedblleft") + (#o253 556.0 "guillemotleft") + (#o254 333.0 "guilsinglleft") + (#o255 333.0 "guilsinglright") + (#o256 611.0 "fi") + (#o257 611.0 "fl") + (#o261 556.0 "endash") + (#o262 556.0 "dagger") + (#o263 556.0 "daggerdbl") + (#o264 278.0 "periodcentered") + (#o266 556.0 "paragraph") + (#o267 350.0 "bullet") + (#o270 278.0 "quotesinglbase") + (#o271 500.0 "quotedblbase") + (#o272 500.0 "quotedblright") + (#o273 556.0 "guillemotright") + (#o274 1000.0 "ellipsis") + (#o275 1000.0 "perthousand") + (#o277 611.0 "questiondown") + (#o301 333.0 "grave") + (#o302 333.0 "acute") + (#o303 333.0 "circumflex") + (#o304 333.0 "tilde") + (#o305 333.0 "macron") + (#o306 333.0 "breve") + (#o307 333.0 "dotaccent") + (#o310 333.0 "dieresis") + (#o312 333.0 "ring") + (#o313 333.0 "cedilla") + (#o315 333.0 "hungarumlaut") + (#o316 333.0 "ogonek") + (#o317 333.0 "caron") + (#o320 1000.0 "emdash") + (#o341 1000.0 "AE") + (#o343 370.0 "ordfeminine") + (#o350 611.0 "Lslash") + (#o351 778.0 "Oslash") + (#o352 1000.0 "OE") + (#o353 365.0 "ordmasculine") + (#o361 889.0 "ae") + (#o365 278.0 "dotlessi") + (#o370 278.0 "lslash") + (#o371 611.0 "oslash") + (#o372 944.0 "oe") + (#o373 611.0 "germandbls") + )) + + +;;; In fact, the Courier metrics never get used because they are fixed-width +;;; fonts that get handled specially by the PostScript code itself. + +(setup-laserwriter-metrics + '(("Courier" 1000 (0 -251 600 700)) + (#o040 600.0 "space") + (#o041 600.0 "exclam") + (#o042 600.0 "quotedbl") + (#o043 600.0 "numbersign") + (#o044 600.0 "dollar") + (#o045 600.0 "percent") + (#o046 600.0 "ampersand") + (#o047 600.0 "quoteright") + (#o050 600.0 "parenleft") + (#o051 600.0 "parenright") + (#o052 600.0 "asterisk") + (#o053 600.0 "plus") + (#o054 600.0 "comma") + (#o055 600.0 "hyphen") + (#o056 600.0 "period") + (#o057 600.0 "slash") + (#o060 600.0 "zero") + (#o061 600.0 "one") + (#o062 600.0 "two") + (#o063 600.0 "three") + (#o064 600.0 "four") + (#o065 600.0 "five") + (#o066 600.0 "six") + (#o067 600.0 "seven") + (#o070 600.0 "eight") + (#o071 600.0 "nine") + (#o072 600.0 "colon") + (#o073 600.0 "semicolon") + (#o074 600.0 "less") + (#o075 600.0 "equal") + (#o076 600.0 "greater") + (#o077 600.0 "question") + (#o100 600.0 "at") + (#o101 600.0 "A") + (#o102 600.0 "B") + (#o103 600.0 "C") + (#o104 600.0 "D") + (#o105 600.0 "E") + (#o106 600.0 "F") + (#o107 600.0 "G") + (#o110 600.0 "H") + (#o111 600.0 "I") + (#o112 600.0 "J") + (#o113 600.0 "K") + (#o114 600.0 "L") + (#o115 600.0 "M") + (#o116 600.0 "N") + (#o117 600.0 "O") + (#o120 600.0 "P") + (#o121 600.0 "Q") + (#o122 600.0 "R") + (#o123 600.0 "S") + (#o124 600.0 "T") + (#o125 600.0 "U") + (#o126 600.0 "V") + (#o127 600.0 "W") + (#o130 600.0 "X") + (#o131 600.0 "Y") + (#o132 600.0 "Z") + (#o133 600.0 "bracketleft") + (#o134 600.0 "backslash") + (#o135 600.0 "bracketright") + (#o136 600.0 "asciicircum") + (#o137 600.0 "underscore") + (#o140 600.0 "quoteleft") + (#o141 600.0 "a") + (#o142 600.0 "b") + (#o143 600.0 "c") + (#o144 600.0 "d") + (#o145 600.0 "e") + (#o146 600.0 "f") + (#o147 600.0 "g") + (#o150 600.0 "h") + (#o151 600.0 "i") + (#o152 600.0 "j") + (#o153 600.0 "k") + (#o154 600.0 "l") + (#o155 600.0 "m") + (#o156 600.0 "n") + (#o157 600.0 "o") + (#o160 600.0 "p") + (#o161 600.0 "q") + (#o162 600.0 "r") + (#o163 600.0 "s") + (#o164 600.0 "t") + (#o165 600.0 "u") + (#o166 600.0 "v") + (#o167 600.0 "w") + (#o170 600.0 "x") + (#o171 600.0 "y") + (#o172 600.0 "z") + (#o173 600.0 "braceleft") + (#o174 600.0 "bar") + (#o175 600.0 "braceright") + (#o176 600.0 "asciitilde") + (#o241 600.0 "exclamdown") + (#o242 600.0 "cent") + (#o243 600.0 "sterling") + (#o244 600.0 "fraction") + (#o245 600.0 "yen") + (#o246 600.0 "florin") + (#o247 600.0 "section") + (#o250 600.0 "currency") + (#o251 600.0 "quotesingle") + (#o252 600.0 "quotedblleft") + (#o253 600.0 "guillemotleft") + (#o254 600.0 "guilsinglleft") + (#o255 600.0 "guilsinglright") + (#o256 600.0 "fi") + (#o257 600.0 "fl") + (#o261 600.0 "endash") + (#o262 600.0 "dagger") + (#o263 600.0 "daggerdbl") + (#o264 600.0 "periodcentered") + (#o266 600.0 "paragraph") + (#o267 600.0 "bullet") + (#o270 600.0 "quotesinglbase") + (#o271 600.0 "quotedblbase") + (#o272 600.0 "quotedblright") + (#o273 600.0 "guillemotright") + (#o274 600.0 "ellipsis") + (#o275 600.0 "perthousand") + (#o277 600.0 "questiondown") + (#o301 600.0 "grave") + (#o302 600.0 "acute") + (#o303 600.0 "circumflex") + (#o304 600.0 "tilde") + (#o305 600.0 "macron") + (#o306 600.0 "breve") + (#o307 600.0 "dotaccent") + (#o310 600.0 "dieresis") + (#o312 600.0 "ring") + (#o313 600.0 "cedilla") + (#o315 600.0 "hungarumlaut") + (#o316 600.0 "ogonek") + (#o317 600.0 "caron") + (#o320 600.0 "emdash") + (#o341 600.0 "AE") + (#o343 600.0 "ordfeminine") + (#o350 600.0 "Lslash") + (#o351 600.0 "Oslash") + (#o352 600.0 "OE") + (#o353 600.0 "ordmasculine") + (#o361 600.0 "ae") + (#o365 600.0 "dotlessi") + (#o370 600.0 "lslash") + (#o371 600.0 "oslash") + (#o372 600.0 "oe") + (#o373 600.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Courier-Oblique" 1000 (0 -251 600 700)) + (#o040 600.0 "space") + (#o041 600.0 "exclam") + (#o042 600.0 "quotedbl") + (#o043 600.0 "numbersign") + (#o044 600.0 "dollar") + (#o045 600.0 "percent") + (#o046 600.0 "ampersand") + (#o047 600.0 "quoteright") + (#o050 600.0 "parenleft") + (#o051 600.0 "parenright") + (#o052 600.0 "asterisk") + (#o053 600.0 "plus") + (#o054 600.0 "comma") + (#o055 600.0 "hyphen") + (#o056 600.0 "period") + (#o057 600.0 "slash") + (#o060 600.0 "zero") + (#o061 600.0 "one") + (#o062 600.0 "two") + (#o063 600.0 "three") + (#o064 600.0 "four") + (#o065 600.0 "five") + (#o066 600.0 "six") + (#o067 600.0 "seven") + (#o070 600.0 "eight") + (#o071 600.0 "nine") + (#o072 600.0 "colon") + (#o073 600.0 "semicolon") + (#o074 600.0 "less") + (#o075 600.0 "equal") + (#o076 600.0 "greater") + (#o077 600.0 "question") + (#o100 600.0 "at") + (#o101 600.0 "A") + (#o102 600.0 "B") + (#o103 600.0 "C") + (#o104 600.0 "D") + (#o105 600.0 "E") + (#o106 600.0 "F") + (#o107 600.0 "G") + (#o110 600.0 "H") + (#o111 600.0 "I") + (#o112 600.0 "J") + (#o113 600.0 "K") + (#o114 600.0 "L") + (#o115 600.0 "M") + (#o116 600.0 "N") + (#o117 600.0 "O") + (#o120 600.0 "P") + (#o121 600.0 "Q") + (#o122 600.0 "R") + (#o123 600.0 "S") + (#o124 600.0 "T") + (#o125 600.0 "U") + (#o126 600.0 "V") + (#o127 600.0 "W") + (#o130 600.0 "X") + (#o131 600.0 "Y") + (#o132 600.0 "Z") + (#o133 600.0 "bracketleft") + (#o134 600.0 "backslash") + (#o135 600.0 "bracketright") + (#o136 600.0 "asciicircum") + (#o137 600.0 "underscore") + (#o140 600.0 "quoteleft") + (#o141 600.0 "a") + (#o142 600.0 "b") + (#o143 600.0 "c") + (#o144 600.0 "d") + (#o145 600.0 "e") + (#o146 600.0 "f") + (#o147 600.0 "g") + (#o150 600.0 "h") + (#o151 600.0 "i") + (#o152 600.0 "j") + (#o153 600.0 "k") + (#o154 600.0 "l") + (#o155 600.0 "m") + (#o156 600.0 "n") + (#o157 600.0 "o") + (#o160 600.0 "p") + (#o161 600.0 "q") + (#o162 600.0 "r") + (#o163 600.0 "s") + (#o164 600.0 "t") + (#o165 600.0 "u") + (#o166 600.0 "v") + (#o167 600.0 "w") + (#o170 600.0 "x") + (#o171 600.0 "y") + (#o172 600.0 "z") + (#o173 600.0 "braceleft") + (#o174 600.0 "bar") + (#o175 600.0 "braceright") + (#o176 600.0 "asciitilde") + (#o241 600.0 "exclamdown") + (#o242 600.0 "cent") + (#o243 600.0 "sterling") + (#o244 600.0 "fraction") + (#o245 600.0 "yen") + (#o246 600.0 "florin") + (#o247 600.0 "section") + (#o250 600.0 "currency") + (#o251 600.0 "quotesingle") + (#o252 600.0 "quotedblleft") + (#o253 600.0 "guillemotleft") + (#o254 600.0 "guilsinglleft") + (#o255 600.0 "guilsinglright") + (#o256 600.0 "fi") + (#o257 600.0 "fl") + (#o261 600.0 "endash") + (#o262 600.0 "dagger") + (#o263 600.0 "daggerdbl") + (#o264 600.0 "periodcentered") + (#o266 600.0 "paragraph") + (#o267 600.0 "bullet") + (#o270 600.0 "quotesinglbase") + (#o271 600.0 "quotedblbase") + (#o272 600.0 "quotedblright") + (#o273 600.0 "guillemotright") + (#o274 600.0 "ellipsis") + (#o275 600.0 "perthousand") + (#o277 600.0 "questiondown") + (#o301 600.0 "grave") + (#o302 600.0 "acute") + (#o303 600.0 "circumflex") + (#o304 600.0 "tilde") + (#o305 600.0 "macron") + (#o306 600.0 "breve") + (#o307 600.0 "dotaccent") + (#o310 600.0 "dieresis") + (#o312 600.0 "ring") + (#o313 600.0 "cedilla") + (#o315 600.0 "hungarumlaut") + (#o316 600.0 "ogonek") + (#o317 600.0 "caron") + (#o320 600.0 "emdash") + (#o341 600.0 "AE") + (#o343 600.0 "ordfeminine") + (#o350 600.0 "Lslash") + (#o351 600.0 "Oslash") + (#o352 600.0 "OE") + (#o353 600.0 "ordmasculine") + (#o361 600.0 "ae") + (#o365 600.0 "dotlessi") + (#o370 600.0 "lslash") + (#o371 600.0 "oslash") + (#o372 600.0 "oe") + (#o373 600.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Courier-Bold" 1000 (0 -251 600 700)) + (#o040 600.0 "space") + (#o041 600.0 "exclam") + (#o042 600.0 "quotedbl") + (#o043 600.0 "numbersign") + (#o044 600.0 "dollar") + (#o045 600.0 "percent") + (#o046 600.0 "ampersand") + (#o047 600.0 "quoteright") + (#o050 600.0 "parenleft") + (#o051 600.0 "parenright") + (#o052 600.0 "asterisk") + (#o053 600.0 "plus") + (#o054 600.0 "comma") + (#o055 600.0 "hyphen") + (#o056 600.0 "period") + (#o057 600.0 "slash") + (#o060 600.0 "zero") + (#o061 600.0 "one") + (#o062 600.0 "two") + (#o063 600.0 "three") + (#o064 600.0 "four") + (#o065 600.0 "five") + (#o066 600.0 "six") + (#o067 600.0 "seven") + (#o070 600.0 "eight") + (#o071 600.0 "nine") + (#o072 600.0 "colon") + (#o073 600.0 "semicolon") + (#o074 600.0 "less") + (#o075 600.0 "equal") + (#o076 600.0 "greater") + (#o077 600.0 "question") + (#o100 600.0 "at") + (#o101 600.0 "A") + (#o102 600.0 "B") + (#o103 600.0 "C") + (#o104 600.0 "D") + (#o105 600.0 "E") + (#o106 600.0 "F") + (#o107 600.0 "G") + (#o110 600.0 "H") + (#o111 600.0 "I") + (#o112 600.0 "J") + (#o113 600.0 "K") + (#o114 600.0 "L") + (#o115 600.0 "M") + (#o116 600.0 "N") + (#o117 600.0 "O") + (#o120 600.0 "P") + (#o121 600.0 "Q") + (#o122 600.0 "R") + (#o123 600.0 "S") + (#o124 600.0 "T") + (#o125 600.0 "U") + (#o126 600.0 "V") + (#o127 600.0 "W") + (#o130 600.0 "X") + (#o131 600.0 "Y") + (#o132 600.0 "Z") + (#o133 600.0 "bracketleft") + (#o134 600.0 "backslash") + (#o135 600.0 "bracketright") + (#o136 600.0 "asciicircum") + (#o137 600.0 "underscore") + (#o140 600.0 "quoteleft") + (#o141 600.0 "a") + (#o142 600.0 "b") + (#o143 600.0 "c") + (#o144 600.0 "d") + (#o145 600.0 "e") + (#o146 600.0 "f") + (#o147 600.0 "g") + (#o150 600.0 "h") + (#o151 600.0 "i") + (#o152 600.0 "j") + (#o153 600.0 "k") + (#o154 600.0 "l") + (#o155 600.0 "m") + (#o156 600.0 "n") + (#o157 600.0 "o") + (#o160 600.0 "p") + (#o161 600.0 "q") + (#o162 600.0 "r") + (#o163 600.0 "s") + (#o164 600.0 "t") + (#o165 600.0 "u") + (#o166 600.0 "v") + (#o167 600.0 "w") + (#o170 600.0 "x") + (#o171 600.0 "y") + (#o172 600.0 "z") + (#o173 600.0 "braceleft") + (#o174 600.0 "bar") + (#o175 600.0 "braceright") + (#o176 600.0 "asciitilde") + (#o241 600.0 "exclamdown") + (#o242 600.0 "cent") + (#o243 600.0 "sterling") + (#o244 600.0 "fraction") + (#o245 600.0 "yen") + (#o246 600.0 "florin") + (#o247 600.0 "section") + (#o250 600.0 "currency") + (#o251 600.0 "quotesingle") + (#o252 600.0 "quotedblleft") + (#o253 600.0 "guillemotleft") + (#o254 600.0 "guilsinglleft") + (#o255 600.0 "guilsinglright") + (#o256 600.0 "fi") + (#o257 600.0 "fl") + (#o261 600.0 "endash") + (#o262 600.0 "dagger") + (#o263 600.0 "daggerdbl") + (#o264 600.0 "periodcentered") + (#o266 600.0 "paragraph") + (#o267 600.0 "bullet") + (#o270 600.0 "quotesinglbase") + (#o271 600.0 "quotedblbase") + (#o272 600.0 "quotedblright") + (#o273 600.0 "guillemotright") + (#o274 600.0 "ellipsis") + (#o275 600.0 "perthousand") + (#o277 600.0 "questiondown") + (#o301 600.0 "grave") + (#o302 600.0 "acute") + (#o303 600.0 "circumflex") + (#o304 600.0 "tilde") + (#o305 600.0 "macron") + (#o306 600.0 "breve") + (#o307 600.0 "dotaccent") + (#o310 600.0 "dieresis") + (#o312 600.0 "ring") + (#o313 600.0 "cedilla") + (#o315 600.0 "hungarumlaut") + (#o316 600.0 "ogonek") + (#o317 600.0 "caron") + (#o320 600.0 "emdash") + (#o341 600.0 "AE") + (#o343 600.0 "ordfeminine") + (#o350 600.0 "Lslash") + (#o351 600.0 "Oslash") + (#o352 600.0 "OE") + (#o353 600.0 "ordmasculine") + (#o361 600.0 "ae") + (#o365 600.0 "dotlessi") + (#o370 600.0 "lslash") + (#o371 600.0 "oslash") + (#o372 600.0 "oe") + (#o373 600.0 "germandbls") + )) + +(setup-laserwriter-metrics + '(("Courier-BoldOblique" 1000 (0 -251 600 700)) + (#o040 600.0 "space") + (#o041 600.0 "exclam") + (#o042 600.0 "quotedbl") + (#o043 600.0 "numbersign") + (#o044 600.0 "dollar") + (#o045 600.0 "percent") + (#o046 600.0 "ampersand") + (#o047 600.0 "quoteright") + (#o050 600.0 "parenleft") + (#o051 600.0 "parenright") + (#o052 600.0 "asterisk") + (#o053 600.0 "plus") + (#o054 600.0 "comma") + (#o055 600.0 "hyphen") + (#o056 600.0 "period") + (#o057 600.0 "slash") + (#o060 600.0 "zero") + (#o061 600.0 "one") + (#o062 600.0 "two") + (#o063 600.0 "three") + (#o064 600.0 "four") + (#o065 600.0 "five") + (#o066 600.0 "six") + (#o067 600.0 "seven") + (#o070 600.0 "eight") + (#o071 600.0 "nine") + (#o072 600.0 "colon") + (#o073 600.0 "semicolon") + (#o074 600.0 "less") + (#o075 600.0 "equal") + (#o076 600.0 "greater") + (#o077 600.0 "question") + (#o100 600.0 "at") + (#o101 600.0 "A") + (#o102 600.0 "B") + (#o103 600.0 "C") + (#o104 600.0 "D") + (#o105 600.0 "E") + (#o106 600.0 "F") + (#o107 600.0 "G") + (#o110 600.0 "H") + (#o111 600.0 "I") + (#o112 600.0 "J") + (#o113 600.0 "K") + (#o114 600.0 "L") + (#o115 600.0 "M") + (#o116 600.0 "N") + (#o117 600.0 "O") + (#o120 600.0 "P") + (#o121 600.0 "Q") + (#o122 600.0 "R") + (#o123 600.0 "S") + (#o124 600.0 "T") + (#o125 600.0 "U") + (#o126 600.0 "V") + (#o127 600.0 "W") + (#o130 600.0 "X") + (#o131 600.0 "Y") + (#o132 600.0 "Z") + (#o133 600.0 "bracketleft") + (#o134 600.0 "backslash") + (#o135 600.0 "bracketright") + (#o136 600.0 "asciicircum") + (#o137 600.0 "underscore") + (#o140 600.0 "quoteleft") + (#o141 600.0 "a") + (#o142 600.0 "b") + (#o143 600.0 "c") + (#o144 600.0 "d") + (#o145 600.0 "e") + (#o146 600.0 "f") + (#o147 600.0 "g") + (#o150 600.0 "h") + (#o151 600.0 "i") + (#o152 600.0 "j") + (#o153 600.0 "k") + (#o154 600.0 "l") + (#o155 600.0 "m") + (#o156 600.0 "n") + (#o157 600.0 "o") + (#o160 600.0 "p") + (#o161 600.0 "q") + (#o162 600.0 "r") + (#o163 600.0 "s") + (#o164 600.0 "t") + (#o165 600.0 "u") + (#o166 600.0 "v") + (#o167 600.0 "w") + (#o170 600.0 "x") + (#o171 600.0 "y") + (#o172 600.0 "z") + (#o173 600.0 "braceleft") + (#o174 600.0 "bar") + (#o175 600.0 "braceright") + (#o176 600.0 "asciitilde") + (#o241 600.0 "exclamdown") + (#o242 600.0 "cent") + (#o243 600.0 "sterling") + (#o244 600.0 "fraction") + (#o245 600.0 "yen") + (#o246 600.0 "florin") + (#o247 600.0 "section") + (#o250 600.0 "currency") + (#o251 600.0 "quotesingle") + (#o252 600.0 "quotedblleft") + (#o253 600.0 "guillemotleft") + (#o254 600.0 "guilsinglleft") + (#o255 600.0 "guilsinglright") + (#o256 600.0 "fi") + (#o257 600.0 "fl") + (#o261 600.0 "endash") + (#o262 600.0 "dagger") + (#o263 600.0 "daggerdbl") + (#o264 600.0 "periodcentered") + (#o266 600.0 "paragraph") + (#o267 600.0 "bullet") + (#o270 600.0 "quotesinglbase") + (#o271 600.0 "quotedblbase") + (#o272 600.0 "quotedblright") + (#o273 600.0 "guillemotright") + (#o274 600.0 "ellipsis") + (#o275 600.0 "perthousand") + (#o277 600.0 "questiondown") + (#o301 600.0 "grave") + (#o302 600.0 "acute") + (#o303 600.0 "circumflex") + (#o304 600.0 "tilde") + (#o305 600.0 "macron") + (#o306 600.0 "breve") + (#o307 600.0 "dotaccent") + (#o310 600.0 "dieresis") + (#o312 600.0 "ring") + (#o313 600.0 "cedilla") + (#o315 600.0 "hungarumlaut") + (#o316 600.0 "ogonek") + (#o317 600.0 "caron") + (#o320 600.0 "emdash") + (#o341 600.0 "AE") + (#o343 600.0 "ordfeminine") + (#o350 600.0 "Lslash") + (#o351 600.0 "Oslash") + (#o352 600.0 "OE") + (#o353 600.0 "ordmasculine") + (#o361 600.0 "ae") + (#o365 600.0 "dotlessi") + (#o370 600.0 "lslash") + (#o371 600.0 "oslash") + (#o372 600.0 "oe") + (#o373 600.0 "germandbls") + )) + + +(setup-laserwriter-metrics + '(("Symbol" 1000 (-180 -293 1090 1010)) + (#o040 250.0 "space") + (#o041 333.0 "exclam") + (#o042 713.0 "universal") + (#o043 500.0 "numbersign") + (#o044 549.0 "existential") + (#o045 833.0 "percent") + (#o046 778.0 "ampersand") + (#o047 439.0 "suchthat") + (#o050 333.0 "parenleft") + (#o051 333.0 "parenright") + (#o052 500.0 "asteriskmath") + (#o053 549.0 "plus") + (#o054 250.0 "comma") + (#o055 549.0 "minus") + (#o056 250.0 "period") + (#o057 278.0 "slash") + (#o060 500.0 "zero") + (#o061 500.0 "one") + (#o062 500.0 "two") + (#o063 500.0 "three") + (#o064 500.0 "four") + (#o065 500.0 "five") + (#o066 500.0 "six") + (#o067 500.0 "seven") + (#o070 500.0 "eight") + (#o071 500.0 "nine") + (#o072 278.0 "colon") + (#o073 278.0 "semicolon") + (#o074 549.0 "less") + (#o075 549.0 "equal") + (#o076 549.0 "greater") + (#o077 444.0 "question") + (#o100 549.0 "congruent") + (#o101 696.0 "Alpha") + (#o102 660.0 "Beta") + (#o103 710.0 "Chi") + (#o104 612.0 "Delta") + (#o105 652.0 "Epsilon") + (#o106 763.0 "Phi") + (#o107 603.0 "Gamma") + (#o110 765.0 "Eta") + (#o111 351.0 "Iota") + (#o112 631.0 "theta1") + (#o113 724.0 "Kappa") + (#o114 686.0 "Lambda") + (#o115 918.0 "Mu") + (#o116 739.0 "Nu") + (#o117 750.0 "Omicron") + (#o120 768.0 "Pi") + (#o121 741.0 "Theta") + (#o122 580.0 "Rho") + (#o123 592.0 "Sigma") + (#o124 632.0 "Tau") + (#o125 690.0 "Upsilon") + (#o126 439.0 "sigma1") + (#o127 768.0 "Omega") + (#o130 645.0 "Xi") + (#o131 795.0 "Psi") + (#o132 650.0 "Zeta") + (#o133 333.0 "bracketleft") + (#o134 863.0 "therefore") + (#o135 333.0 "bracketright") + (#o136 658.0 "perpendicular") + (#o137 500.0 "underscore") + (#o140 500.0 "radicalex") + (#o141 631.0 "alpha") + (#o142 549.0 "beta") + (#o143 549.0 "chi") + (#o144 494.0 "delta") + (#o145 439.0 "epsilon") + (#o146 521.0 "phi") + (#o147 411.0 "gamma") + (#o150 603.0 "eta") + (#o151 329.0 "iota") + (#o152 603.0 "phi1") + (#o153 549.0 "kappa") + (#o154 549.0 "lambda") + (#o155 576.0 "mu") + (#o156 521.0 "nu") + (#o157 549.0 "omicron") + (#o160 549.0 "pi") + (#o161 521.0 "theta") + (#o162 549.0 "rho") + (#o163 603.0 "sigma") + (#o164 439.0 "tau") + (#o165 576.0 "upsilon") + (#o166 713.0 "omega1") + (#o167 686.0 "omega") + (#o170 493.0 "xi") + (#o171 686.0 "psi") + (#o172 494.0 "zeta") + (#o173 480.0 "braceleft") + (#o174 200.0 "bar") + (#o175 480.0 "braceright") + (#o176 549.0 "similar") + (#o241 620.0 "Upsilon1") + (#o242 247.0 "minute") + (#o243 549.0 "lessequal") + (#o244 167.0 "fraction") + (#o245 713.0 "infinity") + (#o246 500.0 "florin") + (#o247 753.0 "club") + (#o250 753.0 "diamond") + (#o251 753.0 "heart") + (#o252 753.0 "spade") + (#o253 1042.0 "arrowboth") + (#o254 987.0 "arrowleft") + (#o255 603.0 "arrowup") + (#o256 987.0 "arrowright") + (#o257 603.0 "arrowdown") + (#o260 400.0 "degree") + (#o261 549.0 "plusminus") + (#o262 411.0 "second") + (#o263 549.0 "greaterequal") + (#o264 549.0 "multiply") + (#o265 713.0 "proportional") + (#o266 494.0 "partialdiff") + (#o267 460.0 "bullet") + (#o270 549.0 "divide") + (#o271 549.0 "notequal") + (#o272 549.0 "equivalence") + (#o273 549.0 "approxequal") + (#o274 1000.0 "ellipsis") + (#o275 603.0 "arrowvertex") + (#o276 1000.0 "arrowhorizex") + (#o277 658.0 "carriagereturn") + (#o300 823.0 "aleph") + (#o301 686.0 "Ifraktur") + (#o302 795.0 "Rfraktur") + (#o303 987.0 "weierstrass") + (#o304 768.0 "circlemultiply") + (#o305 768.0 "circleplus") + (#o306 823.0 "emptyset") + (#o307 768.0 "intersection") + (#o310 768.0 "union") + (#o311 713.0 "propersuperset") + (#o312 713.0 "reflexsuperset") + (#o313 713.0 "notsubset") + (#o314 713.0 "propersubset") + (#o315 713.0 "reflexsubset") + (#o316 713.0 "element") + (#o317 713.0 "notelement") + (#o320 768.0 "angle") + (#o321 713.0 "gradient") + (#o322 790.0 "registerserif") + (#o323 790.0 "copyrightserif") + (#o324 890.0 "trademarkserif") + (#o325 823.0 "product") + (#o326 549.0 "radical") + (#o327 250.0 "dotmath") + (#o330 713.0 "logicalnot") + (#o331 603.0 "logicaland") + (#o332 603.0 "logicalor") + (#o333 1042.0 "arrowdblboth") + (#o334 987.0 "arrowdblleft") + (#o335 603.0 "arrowdblup") + (#o336 987.0 "arrowdblright") + (#o337 603.0 "arrowdbldown") + (#o340 494.0 "lozenge") + (#o341 329.0 "angleleft") + (#o342 790.0 "registersans") + (#o343 790.0 "copyrightsans") + (#o344 786.0 "trademarksans") + (#o345 713.0 "summation") + (#o346 384.0 "parenlefttp") + (#o347 384.0 "parenleftex") + (#o350 384.0 "parenleftbt") + (#o351 384.0 "bracketlefttp") + (#o352 384.0 "bracketleftex") + (#o353 384.0 "bracketleftbt") + (#o354 494.0 "bracelefttp") + (#o355 494.0 "braceleftmid") + (#o356 494.0 "braceleftbt") + (#o357 494.0 "braceex") + (#o360 790.0 "apple") + (#o361 329.0 "angleright") + (#o362 274.0 "integral") + (#o363 686.0 "integraltp") + (#o364 686.0 "integralex") + (#o365 686.0 "integralbt") + (#o366 384.0 "parenrighttp") + (#o367 384.0 "parenrightex") + (#o370 384.0 "parenrightbt") + (#o371 384.0 "bracketrighttp") + (#o372 384.0 "bracketrightex") + (#o373 384.0 "bracketrightbt") + (#o374 494.0 "bracerighttp") + (#o375 494.0 "bracerightmid") + (#o376 494.0 "bracerightbt") + )) + + +;;; If you suspect the numbers above, you can run this postscript program +;;; (probably by copying it to a file and printing that file) and compare +;;; the numbers that get printed with those of the corresponding fonts and +;;; characters above. Remember that the numbers above are scaled to be +;;; 1000 times as big (second element of the car of the first argument of +;;; SETUP-LASERWRITER-METRICS is the scale factor) as the widths this +;;; program will print. + +#|| +%! +% Postscript program to print out the widths of a representative set of +% characters in each of several fonts. + +% By Mark Nahabedian, 1/8/90, Symbolics Inc. + +% Sample set of characters toprint out widths for: +/TheseChars (1AaMN.ilI!) def + +% Sample sets of fonts to print out widths of characters for: +/TheseFonts [ /Helvetica-BoldOblique /Times-Roman ] def +/CourierFonts [ /Courier /Courier-Bold /Courier-Oblique /Courier-BoldOblique ] def + +% Text 'cursor' positioning stuff: +/StartPage { /y 700 def } def +/NextLine { /y y 20 sub def } def +/Space { ( ) show } def +/Tab0 { 30 y moveto } def +/Tab1 { 178 y moveto } def +/Tab2 { 230 y moveto } def + +/stringbuf 100 string def + +% single character string interval +/DoChar { + Tab1 scaled setfont + dup show + Tab2 unscaled setfont + stringwidth pop stringbuf cvs + scaled setfont show NextLine +} def + +% fontname +/FontSetup { + findfont dup /unscaled exch def + /scaled exch 10 scalefont def +} def + +% X Y +/ShowXandY { + stringbuf cvs show Space + stringbuf cvs show +} def + +% fontdict +/ShowFontBBox { + ([ ) show + dup /FontMatrix get dup 3 -1 roll % stack: fontdict, FontMatrix, FontMatrix + /FontBBox get dup 0 get exch + dup 1 get exch + % stack: BBox, BBox[1], BBox[0], FontMatrix, FontMatrix + 4 1 roll 3 -1 roll + transform exch ShowXandY Space + dup 2 get exch + 3 get + % stack: BBox[3], BBox[2], FontMatrix + 3 -1 roll + transform exch ShowXandY Space + ( ]) show +} def + +% fontname +/DoFont { + dup FontSetup + scaled setfont Tab0 + stringbuf cvs show Tab1 + unscaled ShowFontBBox NextLine + 0 1 TheseChars length 1 sub { TheseChars exch 1 getinterval DoChar } for +} def + +% I tried doing this with forall but it didn't work. + +StartPage +0 1 TheseFonts length 1 sub { TheseFonts exch get DoFont } for +showpage + +StartPage +0 1 CourierFonts length 1 sub { CourierFonts exch get DoFont } for +showpage + +||# diff --git a/pre-silica/postscript-implementation.lisp b/pre-silica/postscript-implementation.lisp new file mode 100644 index 00000000..6fdd387b --- /dev/null +++ b/pre-silica/postscript-implementation.lisp @@ -0,0 +1,1211 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: postscript-implementation.lisp,v 1.5 91/03/26 12:48:27 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; This does not conform to the conventions described under Appendix C: +;;; Structuring Conventions of the PostScript Language Reference Manual. +;;; Part of the reason for non-conformance is the maybe-send-feature +;;; hack. Were it possible for this implementation to send more than +;;; one page to the printer, then the stuff downloaded using the +;;; maybe-send-feature hack would be associated with a single page +;;; rather than with the whole document and reordering of the pages by +;;; some other tool could cause features which were first generated by +;;; one page and later referenced by another to become undefined if +;;; those pages were reordered. The %% comments do conform except for +;;; %%Page and the feature reordering problem. + +;;; Line thickness currently uses "1 setlinewidth" for minimum line +;;; thickness. This can produce a line 2 pixels wide since there can be +;;; 2 pixels that are less than or equal to 1/2 away from the line. "0 +;;; setlinewidth" means to use the minimum for the resolution of the +;;; device. At least now, for the case of line thickness of 1 :normal, this +;;; will use 0 setlinewidth for output to the Apple Laser Writer. + +(defparameter *ps-magic-baseline-factor* 0.2) ;estimation of % baseline to bottom. + +(defparameter *1-pixel=points* 1.2) ;1 "average" pixel is about 1.2 points + +(defmacro round-up (x) + `(floor (+ ,x 0.5))) + +;;--- Convert CLIM units ("pixels") to (printers') points +(defmacro pixels-to-points (&rest pixels) + (let ((forms nil)) + (dolist (pixel pixels) + (push `(setq ,pixel (* ,pixel *1-pixel=points*)) forms)) + `(progn ,@(nreverse forms)))) + +;;--- Convert (printers') points to CLIM units ("pixels") +(defmacro points-to-pixels (&rest points) + (let ((forms nil)) + (dolist (point points) + (push `(setq ,point (round-up (/ ,point *1-pixel=points*))) forms)) + `(progn ,@(nreverse forms)))) + +(defvar *annotate-postscript* nil) + +(defmacro annotating-postscript ((stream printer-stream) &body body) + `(when *annotate-postscript* + (let* ((,printer-stream (slot-value ,stream 'printer-stream)) + (text (with-output-to-string (,printer-stream) ,@body)) + (start 0)) + (loop + (let ((newline (position #\newline text :start start))) + (write-string "% " ,printer-stream) + (write-string text ,printer-stream :start start :end newline) + (unless newline (return)) + (setq start (1+ newline)))) + (fresh-line ,printer-stream)))) + + +;;; How the font hackery works: + +;;; For each CLIM text style used in the output, a corresponding scaled +;;; font must exist in the PostScript engine. (The PostScript books +;;; recommend that for efficiency you cache the results of operations +;;; like scalefont). There is one PS-FONT-COMPAT-KLUDGE structure +;;; created for each CLIM text style used. These structures are stored +;;; in the FONT-MAP slot of POSTSCRIPT-IMPLEMENTATION-MIXIN streams. +;;; Inside the PostScript engine there is a corresponding array named +;;; fontarray, whose i'th element contains the scaled postscript font +;;; object described by the i'th element of FONT-MAP. + +;;; The function GET-FONT-COMPAT-STR is used to find the +;;; PS-FONT-COMPAT-KLUDGE object corresponding to a CLIM text style. +;;; The first time a CLIM text style is encounterred, +;;; GET-FONT-COMPAT-STR creates a PS-FONT-COMPAT-KLUDGE object for it, +;;; stores it in FONT-MAP and generates postscript code to construct the +;;; corresponding scaled postscript font and store it in fontarray +;;; using the postscript estfont procedure defined in the preamble. + +;;; CONVERT-CLIM-TO-PS-FONT-DESCRIPTION converts a CLIM text style, eg. +;;; (:serif :bold :large) to a postscript font description, eg. ("Times" +;;; :bold 12). When estfont is used, it interns a font "Times-Bold" of +;;; size 12 as the appropriate element of fontarray. + +;;; This structure is used to represent a PostScript font masquerading as a +;;; CLIM-world entity. They populate the font-map array of the stream. +(defstruct (ps-font-compat-kludge (:conc-name psfck-)) + index ;index into stream's array. + style-descriptor ;parse-text-style output. + true-ps-descriptor ;("Times" :italic 6 [pts]) + points ;point-size + clim-height ;equivalent size in CLIM "pixels" + clim-ascent ;top-to-baseline, "pixels" + clim-descent ;baseline-to-bottom + width-table) ;width array or constant #. + +;;; Each element is ((family face) width-or-width-table-array height ascent descent) +(defvar *char-width-tables* nil) + +(defun make-new-fcs (text-style index) + (let ((fcs (make-ps-font-compat-kludge + :index index + :style-descriptor text-style + :true-ps-descriptor (convert-clim-to-ps-font-description text-style)))) + (initialize-fcs fcs) + fcs)) + +(defun initialize-fcs (fcs) + (let* ((points (third (psfck-true-ps-descriptor fcs))) + (key `(,(first (psfck-true-ps-descriptor fcs)) + ,(second (psfck-true-ps-descriptor fcs)))) + (metrics (assoc key *char-width-tables* :test #'equal))) + (unless metrics + (error "No font metrics for ~S" key)) + (setf (psfck-points fcs) points) + (let ((width-table (second metrics)) + (height (third metrics)) + (ascent (fourth metrics)) + (descent (fifth metrics))) + (setf (psfck-clim-height fcs) (* points height)) + (setf (psfck-clim-ascent fcs) (* points ascent)) + (setf (psfck-clim-descent fcs) (* points descent)) + (setf (psfck-width-table fcs) width-table))) + nil) + +;;; Each element is composed of: +;;; - a CLIM text family keyword, +;;; - the name of a font to use for that family, +;;; - a list of point sizes corresponding to the text size keywords +;;; in the corresponding positions in *psftd-keywords*. +;;; We should be able to phjase this out since we have a +;;; STANDARDIZE-STYLE method for postscript devices. +(defparameter *postscript-font-translate-data* + '((:fix "Courier" (4 6 7 9 11 14 18)) + (:sans-serif "Helvetica" (5 7 8 10 12 16 20)) + (:serif "Times" (5 7 8 10 12 16 20)))) + +(defparameter *psftd-keywords* '(:tiny :very-small :small :normal :large :very-large :huge)) + +;; The second element is a character size, which is either a number or a +;; place to go looking to get the character width table +(defparameter *ps-font-family-data* + '(("Times" + (nil "tir" "Times-Roman") + (:bold "tib" "Times-Bold") + (:italic "tii" "Times-Italic") + (:bold-italic "tibi" "Times-BoldItalic")) + ("Helvetica" + (nil "he" "Helvetica") + (:bold "heb" "Helvetica-Bold") + (:italic "heo" "Helvetica-Oblique") + (:bold-italic "hebo" "Helvetica-BoldOblique")) + ("Courier" + (nil 0.6 "Courier") + (:bold 0.6 "Courier-Bold") + (:italic 0.6 "Courier-Oblique") + (:bold-italic 0.6 "Courier-BoldOblique")))) + +(defun get-ps-fam-face-name (fcs) + (let ((fam (first (psfck-true-ps-descriptor fcs))) + (face (second (psfck-true-ps-descriptor fcs)))) + (let ((famdata (cdr (or (assoc fam *ps-font-family-data* :test #'string-equal) + (error "No info for PostScript font family ~A" fam))))) + (third (or (assoc face famdata) + (error "No info for PostScript family ~A face ~A." fam face)))))) + +;; Value is a 3 element list acceptable as a returned value from +;; CONVERT-CLIM-TO-PS-FONT-DESCRIPTION: a postscript family name as +;; appears in the CARs of the elements of *PS-FONT-FAMILY-DATA*, a face +;; keyword as returned by the function KEYWORDIFY-STYLE-FACE, and a +;; size in points. +(defparameter *ps-font-description-for-undefined-style* '("Courier" nil 4)) + +(defun convert-clim-to-ps-font-description (style) + (let ((size (text-style-size style)) + (face (keywordify-style-face (text-style-face style))) + (family (text-style-family style))) + (if (and *ps-font-description-for-undefined-style* + (eq style *undefined-text-style*)) + ;;--- Probably pointless to issue any sort of warning here + *ps-font-description-for-undefined-style* + (let* ((famdat (or (assoc family *postscript-font-translate-data*) + (error "Don't have PostScript support for family ~A." family))) + (points (if (numberp size) + size + (point-size-for-size-keyword size famdat))) + (psname (second famdat))) + `(,psname ,face ,points))))) + +(defun keywordify-style-face (n) + (let ((tem (face-code->face n))) + (cond ((eq tem ':roman) nil) + ((atom tem) tem) + ((equal tem '(:bold :italic)) :bold-italic) + ((equal tem '(:italic :bold)) :bold-italic) + (t (list :numeric-code n))))) + +(defun point-size-for-size-keyword (size-keyword family-data) + (nth (or (position size-keyword *psftd-keywords*) + (error "Don't have PostScript support for size ~A." size-keyword)) + (third family-data))) + +;;; This actually reads metrics for the Apple LaserWriter. Some day we +;;; should make the font width table stuff device independent. +;;; The metrics are in sys:clim;laserwriter-metrics.lisp.newest. +;;; That file consists of invocations of this function. +;;; Don't bother loading the width information for fixed width fonts like Courrier +;;; which already have their width hard-coded in *ps-font-family-data*? +(defun setup-laserwriter-metrics (font-info) + (let ((char-widths (cdr font-info)) + (name (caar font-info)) + (scale (cadar font-info)) + (box (caddar font-info)) + (width-table nil)) + (multiple-value-bind (family face size-kludge) + (find-family-and-face-for-postscript-font-name name) + ;; if the kludgy size element of the font's description in + ;; *ps-font-family-data* is a number, just use it instead of + ;; building the width table. + (cond ((numberp size-kludge) + (setq width-table size-kludge)) + (t + (setq width-table (make-array 256)) + (dolist (char-info char-widths) + (let ((char-code (first char-info)) + (char-width (/ (second char-info) scale))) + (setf (aref width-table char-code) char-width))))) + (let ((key `(,family ,face))) + (when (car key) ;check family to make sure we found the name + (let* ((temp (assoc key *char-width-tables* :test #'equal)) + (height (abs (/ (- (fourth box) (second box)) scale))) + (ascent (abs (/ (fourth box) scale))) + (descent (abs (/ (second box) scale))) + (data `(,width-table ,height ,ascent ,descent))) + (if temp + (setf (cdr temp) data) + (push `(,key ,@data) *char-width-tables*)))))))) + +(defun find-family-and-face-for-postscript-font-name (name) + (dolist (family-data *ps-font-family-data*) + (let ((family (car family-data))) + (dolist (face-data (cdr family-data)) + (let ((face (first face-data)) + (size-kludge (second face-data)) + (fname (third face-data))) + (when (string= name fname) + (return-from find-family-and-face-for-postscript-font-name + (values family face size-kludge)))))))) + + +(defclass postscript-implementation-mixin () + ((printer-stream :initarg :stream) + (current-color :initform nil) ;for decoding stippled inks + (features-sent :initform nil) + (curfont :initform nil) ;a psfck structure + (ch1buf :initform (make-array 1 :element-type 'extended-char)) ;used for char ops. + (font-map :initform (make-array 30 :initial-element nil)) + (header-comments :initform nil :initarg :header-comments) + (orientation :initform :portrait :initarg :orientation) + ;; For multi-page output, analogous to a window's scroll position + (viewport-x :initform 0) + (viewport-y :initform 0))) + +(defmethod implementation-pixels-per-point ((stream postscript-implementation-mixin)) + (/ *1-pixel=points*)) + +(defmethod stream-force-output ((stream postscript-implementation-mixin)) + (force-output (slot-value stream 'printer-stream))) + +(defmethod stream-clear-output ((stream postscript-implementation-mixin)) + (clear-output (slot-value stream 'printer-stream))) + +(defmethod stream-finish-output ((stream postscript-implementation-mixin)) + (finish-output (slot-value stream 'printer-stream))) + +;;; Methods that might be needed: +;;; what about other "window" protocols? +;;; host-window-margins +;;; window-margins (being flushed, should return (values 0 0 0 0)) +;;; window-beep +;;; window-clear (do a fresh-page?) + +;;; Support routines + +(defmacro making-ps-array ((printer-stream) &body body) + `(progn (write-string " [ " ,printer-stream) + ,@body + (write-string " ] " ,printer-stream))) + +(defmacro making-ps-hex-string ((printer-stream) &body body) + `(progn (write-char #\< ,printer-stream) + ,@body + (write-char #\> ,printer-stream))) + +(defmacro with-postscript-gsave (stream &body body) + `(flet ((with-gsave-body () ,@body)) + (declare (dynamic-extent #'with-gsave-body)) + (invoke-with-postscript-gsave ,stream #'with-gsave-body))) + +(defmethod invoke-with-postscript-gsave ((stream postscript-implementation-mixin) continuation) + (with-slots (printer-stream) stream + (format printer-stream " gsave~%") + (funcall continuation) + (format printer-stream " grestore~%"))) + +(defmethod maybe-send-feature ((stream postscript-implementation-mixin) + feature-name + code) + (with-slots (features-sent printer-stream) stream + (unless (member feature-name features-sent) + (annotating-postscript (stream printer-stream) + (format printer-stream "---------------- Feature ~A ----------------" + feature-name)) + (write-string code printer-stream) + (annotating-postscript (stream printer-stream) + (format printer-stream "---------------- End Feature ~A ----------------" + feature-name)) + (push feature-name features-sent)))) + +(defmethod ps-pos-op ((stream postscript-implementation-mixin) op x y &rest args) + (declare (dynamic-extent args)) + (pixels-to-points x y) + (with-slots (printer-stream display-device-type) stream + (write-char #\space printer-stream) + (ps-optimal-flonize + (+ (* (slot-value display-device-type 'page-indent) + (slot-value display-device-type 'device-units-per-inch)) x) + printer-stream) + (write-char #\space printer-stream) + (ps-optimal-flonize + (- (* (slot-value display-device-type 'page-height) + (slot-value display-device-type 'device-units-per-inch)) y) + printer-stream) + (dolist (arg args) + (write-char #\space printer-stream) + (if (numberp arg) + (ps-optimal-flonize arg printer-stream) + (write arg :stream printer-stream :escape nil))) + (format printer-stream " ~A" op) + (if (string-equal op "m") + (write-char #\space printer-stream) + (terpri printer-stream)))) + +(defmethod ps-rel-pos-op ((stream postscript-implementation-mixin) op x y &rest args) + (declare (dynamic-extent args)) + (pixels-to-points x y) + (with-slots (printer-stream) stream + (write-char #\space printer-stream) + (ps-optimal-flonize x printer-stream) + (write-char #\space printer-stream) + (ps-optimal-flonize (- y) printer-stream) + (dolist (arg args) + (write-char #\space printer-stream) + (if (numberp arg) + (ps-optimal-flonize arg printer-stream) + (write arg :stream printer-stream :escape nil))) + (format printer-stream " ~A~%" op))) + +;;; the software that drives the LGP2 (sys:hardcopy;postscript.lisp) +;;; uses LGP:FAST-PRINT-NUM except for writing transformation matrices, +;;; for which it uses +;;; (prin1 (if (fixp elem) elem (float elem)) output-stream) +;;; and also some cases of Format ~D. +(defun ps-optimal-flonize (n stream) + ;; lifted from definition of LGP:FAST-PRINT-NUM in "Q:>sys>hardcopy>postscript.lisp.1679" + (if (and (not (zerop n)) + (< -1 n 1)) + (format stream "~F" (float n)) + (multiple-value-bind (integer frac) + (etypecase n + (integer (values (abs n) 0)) + (float (truncate (round (* (abs n) 100.)) 100)) + (rational (truncate (round (* (abs n) 100.)) 100))) + (if (>= integer 10000.) + (if (integerp n) + (write n :stream stream :escape nil :base 10 :radix nil) + (format stream "~$" n)) + (let ((from 8) + (negative-p nil)) + (when (minusp n) + (setq negative-p t)) + (with-stack-array (string from :element-type 'extended-char) + (macrolet ((add-char (char) + `(setf (aref string (decf from)) ,char))) + (when (/= frac 0) + (multiple-value-bind (frac1 frac2) + (truncate frac 10.) + (when (/= frac2 0) + (add-char (code-char (+ (char-code #\0) frac2)))) + (add-char (code-char (+ (char-code #\0) frac1)))) + (add-char #\.)) + (let ((digit 0)) + (loop + (multiple-value-setq (integer digit) + (truncate integer 10.)) + (add-char (code-char (+ (char-code #\0) digit))) + (when (zerop integer) (return)))) + (when negative-p (add-char #\-)) + (write-string string stream :start from) + n))))))) + +(defun use-line-style (stream line-style) + (let ((thickness (case (line-style-unit line-style) + (:normal (normal-line-thickness (stream-display-device-type stream) + (line-style-thickness line-style))) + (:points (line-style-thickness line-style)))) + (dashes (line-style-dashes line-style))) + (with-slots (printer-stream) stream + (format printer-stream " ~D setlinewidth~%" thickness) + (when dashes + (making-ps-array (printer-stream) + (let ((limit (length dashes))) + (dotimes (i limit) + (write (elt dashes i) :stream printer-stream :escape nil) + (unless (>= (1+ i) limit) + (write-char #\space printer-stream))))) + (format printer-stream "0 setdash~%"))))) + +(defun color-equal (c1 c2) + (or (eq c1 c2) + (and (colorp c1) + (colorp c2) + (multiple-value-bind (r1 g1 b1) (color-rgb c1) + (multiple-value-bind (r2 g2 b2) (color-rgb c2) + (and (= r1 r2) (= g1 g2) (= b1 b2))))))) + +(defmethod maybe-set-color + ((stream postscript-implementation-mixin) (ink (eql +foreground-ink+))) + (maybe-set-color stream (or (slot-value stream 'current-color) +black+))) + +(defmethod maybe-set-color + ((stream postscript-implementation-mixin) (ink (eql +background-ink+))) + (maybe-set-color stream +white+)) + +(defmethod maybe-set-color + ((stream postscript-implementation-mixin) (ink flipping-ink)) + (error "Postscript devices can't draw with flipping inks.")) + +(defmethod maybe-set-color ((stream postscript-implementation-mixin) (ink color)) + (with-slots (current-color printer-stream) stream + (when (or (null current-color) + (not (color-equal current-color ink))) + (setf current-color ink) + (multiple-value-bind (r g b) (color-rgb ink) + (format printer-stream " ~,2F ~,2F ~,2F setrgbcolor~%" r g b))))) + +(defmethod maybe-set-color ((stream postscript-implementation-mixin) (ink rectangular-tile)) + ;; Handled in the patterned fill/stroke case + ) + +(defmethod maybe-set-color + ((stream postscript-implementation-mixin) (ink contrasting-ink)) + (maybe-set-color stream (make-color-for-contrasting-ink ink))) + +;; "Not suitable for ritual use." +(defparameter *ps-ellipse-code* +" +/emtrx matrix def +/elpd 8 dict def +/ellipse {{arc} ellipsei} def +/ellipsen {{arcn} ellipsei} def +/ellipsei {elpd begin /arcp exch def /ea exch def /sa exch def /yra exch def /xra exch def + /y exch def /x exch def +emtrx currentmatrix +x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def +") + +(defparameter *pattern-code* + ;; for drawing filled patterns + "/imgdict 12 dict def +%draw image. One source pixel to one user space unit. +%width width-rounded-up height +/img { imgdict begin + [/height /bitwidth /width ] {exch def} forall + /nbits bitwidth height mul def + /str 100 string def + nbits 0 ne { + gsave width height scale + bitwidth height true [bitwidth 0 0 height neg 0 height] + { nbits 800 ge {/nbits nbits 800 sub def str} + {nbits 8 idiv string /nbits 0 def} + ifelse + currentfile exch readhexstring pop} + imagemask grestore + } if end + } def +/fmod { 2 copy div floor mul sub } bind def +%draw patterned rectangle. One source pixel to scale device units (ignoring user scale). +%width height pattern scale +/pat { imgdict begin gsave + [/scal /patseq ] {exch def} forall + /patheight patseq length def + /patwidth patseq 0 get length 8 mul def +%back up to an even phase boundary + /pswidth patwidth scal mul def + /psheight patheight scal mul def + pswidth psheight idtransform + 0 0 transform psheight fmod neg exch pswidth fmod neg exch idtransform + 3 -1 roll exch dup 0 gt {add} {exch pop} ifelse + 3 1 roll dup 0 gt {add} {exch pop} ifelse exch 2 copy translate + 3 -1 roll exch abs add 3 1 roll abs add exch dtransform + psheight div abs ceiling cvi patheight mul /height exch def + pswidth div abs ceiling cvi patwidth mul /width exch def + width 0 ne { height 0 ne { + /scanline -1 def /linebits 0 def + width height idtransform abs scale scal dup scale + width height true [width 0 0 height neg 0 height] + { linebits 0 le { /linebits width def + /scanline scanline 1 add patheight mod def + /linepat patseq scanline get def + } if + /linebits linebits patwidth sub def linepat } + imagemask } if } if grestore end + } def +%draw pattern in all of visible area. +%pattern scale opaque-p +/patfill1 { initmatrix clippath +%condition-case for nocurrentpoint, returning empty rectangle + errordict begin + /nocurrentpoint dup dup load exch { pop 0 0 0 0 } def + pathbbox + 6 -2 roll def end + 4 2 roll 2 copy translate 4 -2 roll + 3 -1 roll sub 3 1 roll exch sub exch + 3 -1 roll { 2 copy gsave 1 setgray newpath + 0 0 moveto 0 exch lineto 0 rlineto currentpoint pop 0 lineto + closepath fill grestore } if + 4 -2 roll pat } def +%like fill, etc. but with pattern, scale and opaque-p options. +/patfill { gsave clip patfill1 grestore newpath } def +/pateofill { gsave eoclip patfill1 grestore newpath } def +/patstroke { gsave strokepath clip patfill1 grestore newpath } def + ") + +(defvar *postscript-prologue* + "statusdict /waittimeout 30 put +/fontarray 30 array def +/f {fontarray exch get setfont} def +/estfont {findfont exch scalefont fontarray 3 1 roll put} def +/m {moveto} def +") + +(defmethod postscript-prologue ((stream postscript-implementation-mixin)) + (with-slots (printer-stream header-comments display-device-type orientation) stream + (format printer-stream "%! nonconforming~%") + (format printer-stream "%%Creator: CLIM 1.0~%") + (let ((title (getf header-comments :title))) + (when title + (format printer-stream "%%Title: ~A~%" title))) + (let ((for (or (getf header-comments :for) #+Genera zl:user-id))) + (when for + (format printer-stream "%%For: ~A~%" for))) + #+Genera (format printer-stream "%%CreationDate: ~\\date\\~%" (get-universal-time)) + (format printer-stream "%%DocumentFonts: (atend)~%") + (format printer-stream "%%EndComments~%") + (write-string *postscript-prologue* printer-stream) + (ecase orientation + (:portrait + (format printer-stream + "/format-rotation 0 def ~%/format-y-translation 0 def~%")) + (:landscape + (format printer-stream + "/format-rotation -90 def ~%/format-y-translation ~D def~%" + (* (slot-value display-device-type 'page-width) + (slot-value display-device-type 'device-units-per-inch))))) + (format printer-stream + "/new-matrix {0 format-y-translation translate + format-rotation rotate} def + /new-page {showpage new-matrix} def") + (format printer-stream "%%EndProlog~%") + (format printer-stream "~%new-matrix~%"))) + +(defmethod postscript-epilogue ((stream postscript-implementation-mixin)) + (with-slots (printer-stream font-map) stream + (format printer-stream "showpage~%") + (format printer-stream "%%Trailer~%") + (let ((font-names-used nil)) + (dotimes (index (length font-map)) + (let ((fcs (aref font-map index))) + (when fcs + (pushnew (get-ps-fam-face-name fcs) font-names-used :test #'string-equal)))) + (format printer-stream "%%DocumentFonts:~{~^ ~A~}~%" (nreverse font-names-used))))) + +(defun send-pattern (stream printer-stream pattern) + (maybe-send-feature stream 'pattern-program *pattern-code*) + (making-ps-array (printer-stream) + (let ((height (array-dimension pattern 0)) + (width (array-dimension pattern 1))) + (dotimes (j height) + (making-ps-hex-string (printer-stream) + (send-raster printer-stream pattern 0 j width (1+ j) nil))))) + (terpri printer-stream) + (write-string " 4 true " printer-stream)) + +(defun send-raster (printer-stream raster left top right bottom &optional (terpri t)) + (assert (= bottom (1+ top))) + (unless (zerop (rem right 8)) + (error "Sorry, can't hack right /= 0 (mod 8); you have ~D" right)) + (with-stack-array (arr (array-total-size raster) :element-type '(unsigned-byte 8) + :displaced-to raster) + (with-temporary-string (buf :length 100) + (let ((bytes-per-row (truncate (array-dimension raster 1) 8)) + (bytes-per-raster (ceiling (- right left) 8))) + (let ((toprow (* top bytes-per-row)) + (botrow (* bottom bytes-per-row)) + (bigend-digit-char "084c2a6e195d3b7f") + (j 0) + #+Genera (buf buf) + #+Genera (arr arr)) + #+Genera (declare (sys:array-register bigend-digit-char buf arr)) + (flet ((force-buf () + (setf (fill-pointer buf) j) + (with-temporary-substring (subbuf buf 0 j) + (write-string subbuf printer-stream) + (when terpri + (terpri printer-stream))))) + (do* ((index (- botrow bytes-per-row) (- index bytes-per-row)) + (i index index)) + ((< index toprow)) + (dotimes (n bytes-per-raster) + #-(or Allegro Minima) (declare (ignore n)) + (let ((byte (aref arr i))) + (setf (aref buf j) + (aref bigend-digit-char (ldb (byte 4 0) byte))) + (setf (aref buf (1+ j)) + (aref bigend-digit-char (ldb (byte 4 4) byte))) + (incf i) + (incf j 2) + (when (> j 80) (force-buf))))) + (when (> j 0) (force-buf)))))))) + +(defun ps-fill (stream printer-stream ink) + (cond ((typep ink 'rectangular-tile) + ;;--- Kludgy way to determine whether to use patterned drawing + (multiple-value-bind (array width height) + (decode-tile-as-stipple ink) + (declare (ignore width height)) + (unless array + (error "Rectangular tiles other than stipples are not supported yet.")) + (send-pattern stream printer-stream array) + (format printer-stream " patfill~%"))) + (t + (format printer-stream " fill~%")))) + +(defun ps-stroke (stream printer-stream ink) + (cond ((typep ink 'rectangular-tile) + ;;--- Kludgy way to determine whether to use patterned drawing + (multiple-value-bind (array width height) + (decode-tile-as-stipple ink) + (declare (ignore width height)) + (unless array + (error "Rectangular tiles other than stipples are not supported yet.")) + (send-pattern stream printer-stream array) + (format printer-stream " patstroke~%"))) + (t + (format printer-stream " stroke~%")))) + +(defmacro with-postscript-drawing-options ((stream printer-stream-var + &key ink line-style epilogue (newpath T)) + &body body) + (let ((printer-stream (or printer-stream-var (make-symbol "printer-stream")))) + `(let ((,printer-stream (slot-value ,stream 'printer-stream))) + (when ,line-style + (use-line-style ,stream ,line-style)) + (maybe-set-color ,stream ,ink) + ,@(when newpath `((format ,printer-stream " newpath~%"))) + ,@body + ,@(case epilogue + (:default `((if (null ,line-style) + (ps-fill ,stream ,printer-stream ,ink) + (ps-stroke ,stream ,printer-stream ,ink)))) + (:fill `((ps-fill ,stream ,printer-stream ,ink))) + (:stroke `((ps-stroke ,stream ,printer-stream ,ink))))))) + +(defmethod draw-point-internal ((stream postscript-implementation-mixin) x-offset y-offset + x y ink line-style) + (translate-positions x-offset y-offset x y) + (with-postscript-drawing-options (stream printer-stream + :epilogue :stroke + :ink ink :line-style line-style) + (ps-pos-op stream "m" x y) + (ps-rel-pos-op stream "rlineto" 0 0)) + (annotating-postscript (stream printer-stream) + (format printer-stream " (draw-point-internal ~D ~D ~D ~D ...)" + x-offset y-offset x y))) + +(defmethod draw-line-internal ((stream postscript-implementation-mixin) x-offset y-offset + start-x start-y end-x end-y ink line-style) + (translate-positions x-offset y-offset start-x start-y end-x end-y) + (with-postscript-drawing-options (stream printer-stream + :epilogue :stroke + :ink ink :line-style line-style) + (ps-pos-op stream "m" start-x start-y) + (ps-pos-op stream "lineto" end-x end-y)) + (annotating-postscript (stream printer-stream) + (format printer-stream " (draw-line-internal ~D ~D ~D ~D ~D ~D ...)" + x-offset y-offset start-x start-y end-x end-y))) + +(defmethod draw-rectangle-internal ((stream postscript-implementation-mixin) x-offset y-offset + left top right bottom ink line-style) + (translate-positions x-offset y-offset left top right bottom) + (with-postscript-drawing-options (stream printer-stream + :epilogue :default + :ink ink :line-style line-style) + (ps-pos-op stream "m" left top) + (ps-pos-op stream "lineto" right top) + (ps-pos-op stream "lineto" right bottom) + (ps-pos-op stream "lineto" left bottom) + (format printer-stream " closepath ")) ;no cr + (annotating-postscript (stream printer-stream) + (format printer-stream " (draw-rectangle-internal ~D ~D ~D ~D ~D ~D ...)" + x-offset y-offset left top right bottom))) + +(defmethod draw-polygon-internal ((stream postscript-implementation-mixin) x-offset y-offset + list-of-x-and-ys closed ink line-style) + (let ((points (translate-point-sequence x-offset y-offset list-of-x-and-ys))) + (with-postscript-drawing-options (stream printer-stream + :epilogue :default + :ink ink :line-style line-style) + (let ((start-x (first points)) + (start-y (second points))) + (ps-pos-op stream "m" start-x start-y) + (do* ((points (cddr points) (cddr points)) + (ex (first points) (first points)) + (ey (second points) (second points))) + ((null points) + (when closed + (format printer-stream " closepath "))) + (ps-pos-op stream "lineto" ex ey))) + (annotating-postscript (stream printer-stream) + (format printer-stream " (draw-polygon-internal ~D ~D ~A ...)" + x-offset y-offset list-of-x-and-ys))))) + +(defmethod draw-ellipse-internal ((stream postscript-implementation-mixin) x-offset y-offset + center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle ink line-style) + (maybe-send-feature stream 'ellipse *ps-ellipse-code*) + (translate-positions x-offset y-offset center-x center-y) + (when (null start-angle) + (setq start-angle 0 + end-angle 2pi)) + (when (< end-angle start-angle) + (setq end-angle (+ end-angle 2pi))) + (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 (nyi))) + (pixels-to-points x-radius y-radius) + (flet ((skew-angle (a) + (atan (* (sin a) x-radius) + (* (cos a) y-radius)))) + (with-postscript-drawing-options (stream printer-stream + :epilogue :default + :ink ink :line-style line-style) + (ps-pos-op stream "ellipse" center-x center-y + x-radius y-radius + ;; don't allow the common full-circle case to be + ;; screwed up by floating point error: + (if (zerop start-angle) + 0 + (radians->degrees (skew-angle start-angle))) + (if (= end-angle 2pi) + 360 + (radians->degrees (skew-angle end-angle))))) + (annotating-postscript (stream printer-stream) + (format printer-stream + " (draw-ellipse-internal ~D ~D ~D ~D ~D ~D ~D ~D ~D ~D ...)" + x-offset y-offset + center-x center-y + radius-1-dx radius-1-dy + radius-2-dx radius-2-dy + start-angle end-angle))))) + +;; These 2 clones of draw-string would be much more modular if there +;; were a reasonable way of passing arguments transparently, so that +;; we might be able to share code. +(defmethod draw-string-internal ((stream postscript-implementation-mixin) x-offset y-offset + string x y start end align-x align-y text-style ink) + (unless end + (setq end (length string))) + (translate-positions x-offset y-offset x y) + (let* ((fcs (get-font-compat-str stream text-style)) + (height (round-up (psfck-clim-height fcs))) + (descent (round-up (psfck-clim-descent fcs))) + (ascent (- height descent))) + (incf x (compute-text-x-adjustment + align-x stream string text-style start end)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + ;; do raster/ink stuff. + (set-font-if-needed stream fcs) + (with-postscript-drawing-options (stream printer-stream + :epilogue nil :newpath nil + :ink ink) + (ps-pos-op stream "m" x y) + (carefully-output-ps-showstring printer-stream string start end)) + (annotating-postscript (stream printer-stream) + (format printer-stream " (draw-string-internal ~D ~D ~S ~D ~D ~D ~D ~S ~S ...)" + x-offset y-offset string x y start end align-x align-y)))) + +(defmethod draw-character-internal ((stream postscript-implementation-mixin) x-offset y-offset + character x y align-x align-y text-style ink) + (translate-positions x-offset y-offset x y) + (with-slots (printer-stream ch1buf) stream + (setf (aref ch1buf 0) character) + (let* ((fcs (get-font-compat-str stream text-style)) + (height (round-up (psfck-clim-height fcs))) + (descent (round-up (psfck-clim-descent fcs))) + (ascent (- height descent))) + (incf x (compute-text-x-adjustment + align-x stream character text-style)) + (incf y (compute-text-y-adjustment + align-y descent ascent height)) + ;; do raster/ink stuff. + (set-font-if-needed stream fcs) + (with-postscript-drawing-options (stream printer-stream + :epilogue nil :newpath nil + :ink ink) + (ps-pos-op stream "m" x y) + (carefully-output-ps-showstring printer-stream ch1buf 0 1)) + (annotating-postscript (stream printer-stream) + (format printer-stream " (draw-character-internal ~D ~D ~C ~D ~D ~S ~S ...)" + x-offset y-offset character x y align-x align-y))))) + +(defmethod draw-vertical-string-internal ((stream postscript-implementation-mixin) + x-offset y-offset + string x y start end + align-x align-y text-style ink) + (unless end + (setq end (length string))) + (unless text-style + (setq text-style (stream-merged-text-style stream))) + (translate-positions x-offset y-offset x y) + (let* ((fcs (get-font-compat-str stream text-style)) + (height (round-up (psfck-clim-height fcs))) + (descent (round-up (psfck-clim-descent fcs))) + (ascent (- height descent))) + (let ((x-adjust (compute-text-x-adjustment + align-x stream string text-style start end)) + (y-adjust (compute-text-y-adjustment + align-y descent ascent height))) + (set-font-if-needed stream fcs) + (with-postscript-drawing-options (stream printer-stream + :epilogue nil :newpath nil + :ink ink) + (with-postscript-gsave stream + (ps-pos-op stream "m" x y) + (format printer-stream " currentpoint translate 90 rotate ") + (ps-rel-pos-op stream "rmoveto" x-adjust y-adjust) + (carefully-output-ps-showstring printer-stream string start end)))))) + +;;; provide a way for the "user" to start a new page. +;;; Should this have a different name? +;;; Should this functionality be invoked by wriuting the #\page character? +(defmethod new-page ((stream postscript-implementation-mixin)) + (with-slots (printer-stream orientation) stream + (format printer-stream "new-page~%")) + ;; simulate WINDOW-CLEAR: + (clear-output-history stream) + (when (extended-output-stream-p stream) ;can we assume this? + (stream-set-cursor-position* stream 0 0) + (setf (stream-baseline stream) 0 + (stream-current-line-height stream) 0))) + +(defmacro with-ps-stream-glyph-for-character (&body body) + `(macrolet ((stream-glyph-for-character (stream character style &optional our-font) + `(with-slots (display-device-type) ,stream + (multiple-value-bind (character-set index) + (char-character-set-and-index ,character) + (declare (ignore character-set)) + ;; For now we are asserting that each string passed to WRITE-STRING will + ;; have no style changes within it. This is what our-font is all + ;; about. + (let* ((fcs (or our-font (get-font-compat-str stream ,style))) + (CWT (psfck-width-table fcs)) + (relwidth (if (numberp CWT) + CWT + (aref CWT index))) + (escapement-x (round-up (* (psfck-clim-height fcs) relwidth))) + (escapement-y 0) + (origin-x 0) + (origin-y (round-up (psfck-clim-ascent fcs))) + ;; really ought know real dope, but not avl yet + (bb-x escapement-x) + (bb-y (round-up (psfck-clim-height fcs)))) + (values index fcs escapement-x escapement-y origin-x origin-y + bb-x bb-y (numberp cwt))))))) + ,@body)) + +(defmethod stream-glyph-for-character ((stream postscript-implementation-mixin) + character style &optional our-font) + (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y + fixed-width-font-p)) + (with-ps-stream-glyph-for-character + (stream-glyph-for-character stream character style our-font))) + +(defmethod stream-scan-string-for-writing ((stream postscript-implementation-mixin) string + start end style cursor-x max-x + &optional glyph-buffer) + (declare (type coordinate cursor-x max-x)) + (declare (fixnum start end)) + (with-ps-stream-glyph-for-character + (stream-scan-string-for-writing-body))) + +(defmethod stream-write-string-1 ((stream postscript-implementation-mixin) + glyph-buffer start end font color x y) + (when (<= end start) (return-from stream-write-string-1)) + (let* ((index start) + (index8 0) + (fcs font) + (ascent (round-up (psfck-clim-ascent fcs))) + #+Genera (glyph-buffer glyph-buffer)) + #+Genera (declare (sys:array-register glyph-buffer)) + (with-slots (printer-stream) stream + (with-temporary-string (glyphs8 :length (- end start)) + #+Genera (declare (sys:array-register glyphs8)) + (setf (fill-pointer glyphs8) (- end start)) + (loop + (when (= index end) (return)) + (setf (aref glyphs8 index8) (code-char (aref glyph-buffer index))) + (incf index) + (incf index8)) + (set-font-if-needed stream fcs) + (maybe-set-color stream color) + (ps-pos-op stream "m" x (+ y ascent)) + (carefully-output-ps-showstring printer-stream glyphs8 0 (- end start)))))) + +;;--- It's really marginal that characters don't get buffered into a +;;--- string to be sent all at once. +(defmethod stream-write-char-1 ((stream postscript-implementation-mixin) index font color x y) + (let* ((c (code-char index)) + (fcs font) + (ascent (round-up (psfck-clim-ascent fcs)))) + (with-slots (printer-stream ch1buf) stream + (setf (aref ch1buf 0) c) + (set-font-if-needed stream fcs) + (maybe-set-color stream color) + (ps-pos-op stream "m" x (+ y ascent)) + (carefully-output-ps-showstring printer-stream ch1buf 0 1)))) + +(defmethod set-font-if-needed ((stream postscript-implementation-mixin) fcs) + (with-slots (printer-stream curfont) stream + (unless (eq curfont fcs) + (format printer-stream "~D f " (psfck-index fcs)) + (setf curfont fcs)))) + +(defun carefully-output-ps-showstring (printer-stream data start end) + (assert (<= end (length data))) + (write-char #\( printer-stream) + (loop + (let ((next-special (position-if #'(lambda (char) + (or (eql char #\( ) + (eql char #\) ) + (eql char #\\ ))) + data :start start :end end))) + (write-string data printer-stream :start start :end (or next-special end)) + (when next-special + (write-char #\\ printer-stream) + (write-char (elt data next-special) printer-stream)) + (unless next-special (return)) + (setq start (1+ next-special)))) + (format printer-stream ") show~%")) + +(defmethod get-font-compat-str ((stream postscript-implementation-mixin) text-style) + (with-slots (font-map printer-stream) stream + (let ((styledesc (parse-text-style text-style)) + (al (length font-map))) + (do ((i 0 (1+ i))) + ((>= i al) + (error "Font map overflow for ~S" stream)) + (let ((fcs (aref font-map i))) + (when (null fcs) + (setq fcs (make-new-fcs styledesc i)) + (setf (aref font-map i) fcs) + (format printer-stream "~D ~D /~A estfont~%" + (psfck-index fcs) (psfck-points fcs) (get-ps-fam-face-name fcs)) + (return fcs)) + (when (eq styledesc (psfck-style-descriptor fcs)) + (return fcs))))))) + + +;; PostScript's "default user space" is measured in printers' points. +;; Should these force the stream to map the font and then get the +;; information from the FCS? + +(defmethod text-style-width (text-style (medium postscript-implementation-mixin)) + ;; an 'M' is often square and of height approximating the point size of the font. + ;; should probably consult real metrics. + (text-style-size-in-points text-style medium)) + +(defmethod text-style-height ((text-style standard-text-style) + (medium postscript-implementation-mixin)) + (text-style-size-in-points text-style medium)) + +(defmethod text-style-ascent ((text-style standard-text-style) + (medium postscript-implementation-mixin)) + (* (text-style-height text-style medium) (- 1 *ps-magic-baseline-factor*))) + +(defmethod text-style-descent ((text-style standard-text-style) + (medium postscript-implementation-mixin)) + (* (text-style-height text-style medium) *ps-magic-baseline-factor*)) + +;;;--- This can probably go away when we have standardized text styles. +(defmethod text-style-size-in-points ((text-style standard-text-style) + (medium postscript-implementation-mixin)) + (let* ((family (text-style-family text-style)) + (size (text-style-size text-style)) + (famdat (or (assoc family *postscript-font-translate-data*) + (error "Don't have PostScript support for family ~A." family))) + (points (if (numberp size) + size + (point-size-for-size-keyword size famdat)))) + points)) + +(defmethod text-style-fixed-width-p ((text-style standard-text-style) + (stream postscript-implementation-mixin)) + (let* ((family (text-style-family text-style)) + (face (text-style-face text-style)) + (psfam (or (second (assoc family *postscript-font-translate-data*)) + (error "Don't have PostScript support for family ~A." family))) + (famdat (cdr (or (assoc psfam *ps-font-family-data* :test #'string-equal) + (error "No info for PostScript font family ~A?" psfam)))) + (info (cdr (or (assoc face famdat) + (error "No info for PostScript family ~A face ~A." psfam face)))) + (cname (first info))) + (numberp cname))) + +(defmethod text-size ((stream postscript-implementation-mixin) string + &key (text-style (stream-merged-text-style stream)) (start 0) end) + (when (characterp string) + (setq string (string string) + start 0 + end nil)) + (multiple-value-bind (last-x largest-x last-y total-height baseline) + (stream-string-output-size stream string :text-style text-style :start start :end end) + (values largest-x total-height last-x last-y baseline))) + + +(defclass postscript-device (display-device) + ;; 72 points per inch on PostScript devices + ((device-units-per-inch :initform 72 :allocation :class))) + +(defmethod standardize-text-style ((device postscript-device) character-set style) + (declare (ignore character-set)) + (let ((size (text-style-size style))) + (if (numberp size) + style + (let* ((family (text-style-family style)) + (sizes (third (assoc family *postscript-font-translate-data*))) + (position (position size *psftd-keywords*)) + (new-size (and position (nth position sizes)))) + (cond (new-size + (make-text-style family (text-style-face style) new-size)) + ((eql family :stand-in-for-undefined-style) + (make-text-style family (text-style-face style) 10)) + (t + (cerror "Use the undefined text style stand-in instead" + "This display device does not know how to map the logical text ~ + style size ~S in ~S" + size style) + *undefined-text-style*)))))) + +(defclass apple-laser-writer (postscript-device) + ((x-resolution :initform 300 :allocation :class) ;pixels per inch + (y-resolution :initform 300 :allocation :class) + (page-indent :initform 0.5 :allocation :class) ;in inches + (page-width :initform 7.5 :allocation :class) + (page-height :initform 10.5 :allocation :class))) + +;;; allow a display device to do something appropriate for a line thickness in :normal units +(defgeneric normal-line-thickness (display-device thickness)) + +(defmethod normal-line-thickness ((postscript-device display-device) (thickness number)) + thickness) + +(defmethod normal-line-thickness ((postscript-device apple-laser-writer) (thickness number)) + (if (= thickness 1) + 0 + (* 0.5 thickness (/ (slot-value postscript-device 'device-units-per-inch) + (slot-value postscript-device 'x-resolution))))) + +(define-display-device *postscript-device* apple-laser-writer + :font-for-undefined-style "Courier") + +(defclass postscript-stream + (postscript-implementation-mixin + ;; Following classes' protocols are disjoint + graphics-output-recording + ;; A little wierd, but we need it so that the "viewport" stuff gets + ;; handled during REPLAY of multi-page output + #-Silica output-and-window-protocol-intermediary + output-and-recording-protocol-intermediary + output-recording-mixin + graphics-mixin + output-protocol-mixin) + () + (:default-initargs :display-device-type *postscript-device* + :default-text-margin 1000)) + +(defmethod initialize-instance :after ((stream postscript-stream) &key) + (postscript-prologue stream)) + +(defun make-postscript-stream (stream) + (make-instance 'postscript-stream :stream stream)) + +(defmethod close ((stream postscript-stream) &key abort) + (declare (ignore abort)) + (postscript-epilogue stream)) + +(defmethod window-inside-width ((stream postscript-implementation-mixin)) + (with-slots (display-device-type) stream + (/ (* (slot-value display-device-type 'page-width) + (slot-value display-device-type 'device-units-per-inch)) + *1-pixel=points*))) + +(defmethod drawing-surface-to-viewport-coordinates + ((stream postscript-implementation-mixin) dsx dsy) + (declare (type coordinate dsx dsy)) + (with-slots (viewport-x viewport-y) stream + (declare (type coordinate vx vy)) + (values (- dsx viewport-x) (- dsy viewport-y)))) + +(defmethod stream-ensure-cursor-visible ((stream postscript-implementation-mixin) + &optional cx cy) + (declare (ignore cx cy)) + nil) + +(defmethod stream-move-for-line-height-change ((stream postscript-implementation-mixin) + movement old-height cursor-x cursor-y) + (declare (ignore movement old-height cursor-x cursor-y))) + +;; Replay some PostScript output, breaking it into multiple pages +(defmethod stream-replay ((stream postscript-implementation-mixin) &optional region) + (with-slots (output-record record-p draw-p display-device-type + printer-stream orientation viewport-x viewport-y) stream + (when draw-p + (when output-record + (letf-globally ((record-p nil)) + (if region + (replay output-record stream region) + (with-bounding-rectangle* (left top right bottom) output-record + (let* ((page-width + (floor (* (slot-value display-device-type 'page-width) + (slot-value display-device-type 'device-units-per-inch)) + *1-pixel=points*)) + (page-height + (floor (* (slot-value display-device-type 'page-height) + (slot-value display-device-type 'device-units-per-inch)) + *1-pixel=points*)) + (first-page t)) + (setq viewport-x 0 viewport-y 0) + ;; Draw each chunk of output on its own page + (unwind-protect + (do ((y top (+ y page-height))) + ((> y bottom)) + (do ((x left (+ x page-width))) + ((> x right)) + (if first-page + (setq first-page nil) + (format printer-stream "new-page~%")) + (let ((region (make-bounding-rectangle + x y (+ x page-width) (+ y page-height)))) + (replay output-record stream region)) + (incf viewport-x page-width)) + (setf viewport-x 0) + (incf viewport-y page-height)) + (setq viewport-x 0 viewport-y 0)))))))))) + + +(defmacro with-output-to-postscript-stream ((stream-var file-stream &rest args) &body body) + (declare (arglist (stream-var file-stream + &key (display-device *postscript-device*) + header-comments multi-page + (orientation :portrait)) + &body body)) + `(flet ((postscript-output-body (,stream-var) ,@body)) + (declare (dynamic-extent #'postscript-output-body)) + (invoke-with-output-to-postscript-stream ,file-stream #'postscript-output-body ,@args))) + +;; This could really be WITH-OPEN-STREAM, but that isn't going to call CLIM:CLOSE. +;; Fixed in the CLOS stream system. +(defun invoke-with-output-to-postscript-stream (file-stream continuation + &key (display-device *postscript-device*) + header-comments multi-page + (orientation :portrait)) + (let ((postscript-stream (make-instance 'postscript-stream + :stream file-stream + :display-device-type display-device + :header-comments header-comments + :orientation orientation)) + (abort-p t)) + (with-output-recording-options (postscript-stream :record t :draw (not multi-page)) + (unwind-protect + (multiple-value-prog1 + (funcall continuation postscript-stream) + (when multi-page + ;; In the case of multi-page output, we have not actually output + ;; anything to the printer yet. Do so now, breaking the output + ;; up into multiple pages. + (with-output-recording-options (postscript-stream :record nil :draw t) + (frame-replay *application-frame* postscript-stream))) + (setq abort-p nil)) + (close postscript-stream :abort abort-p))))) diff --git a/pre-silica/protocol-intermediaries.lisp b/pre-silica/protocol-intermediaries.lisp new file mode 100644 index 00000000..94c3603f --- /dev/null +++ b/pre-silica/protocol-intermediaries.lisp @@ -0,0 +1,98 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: protocol-intermediaries.lisp,v 1.4 91/03/26 12:48:44 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1989, 1990 International Lisp Associates. All rights reserved." + +;;; Methods for streams that are both windows and extended input streams + +(defmethod stream-note-pointer-button-press :around + ((window input-and-window-protocol-intermediary) pointer button modifier-state x y) + (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y) + (call-next-method window pointer button modifier-state nx ny))) + +(defmethod stream-note-pointer-button-release :around + ((window input-and-window-protocol-intermediary) pointer button modifier-state x y) + (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y) + (call-next-method window pointer button modifier-state nx ny))) + +(defmethod stream-pointer-position* :around ((window input-and-window-protocol-intermediary) + &rest args) + (declare (ignore args)) + (multiple-value-bind (x y) + (call-next-method) + (viewport-to-drawing-surface-coordinates window x y))) + +(defmethod stream-set-pointer-position* :around + ((window input-and-window-protocol-intermediary) x y &key pointer) + (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y) + (call-next-method window nx ny :pointer pointer))) + +(defmethod stream-set-cursor-position* :after ((window input-and-window-protocol-intermediary) + x y) + (let ((cursor (stream-text-cursor window))) + (when cursor + (cursor-set-position* cursor x y)))) + +(defmethod stream-set-cursor-position*-internal :after + ((window input-and-window-protocol-intermediary) x y) + (let ((cursor (stream-text-cursor window))) + (when cursor + (cursor-set-position* cursor x y)))) + + +;;; Methods for streams that are both windows and extended output streams + +(defmethod stream-write-string-1 :around ((window output-and-window-protocol-intermediary) + glyph-buffer start end font color x y) + (multiple-value-bind (nx ny) (drawing-surface-to-viewport-coordinates window x y) + (call-next-method window glyph-buffer start end font color nx ny))) + +(defmethod stream-write-char-1 :around ((window output-and-window-protocol-intermediary) + index font color x y) + (multiple-value-bind (nx ny) (drawing-surface-to-viewport-coordinates window x y) + (call-next-method window index font color nx ny))) + +(defmethod window-note-size-or-position-change :around + ((window output-and-window-protocol-intermediary) + new-left new-top new-right new-bottom) + ;; we have to use UNWIND-PROTECT because some method may throw... + ;; Yecch. Can't there be a better way? + (unwind-protect + (call-next-method window new-left new-top new-right new-bottom) + (let ((width (window-inside-width window))) + (setf (stream-default-text-margin window) width)))) + +#-Silica +(defmethod bounding-rectangle-set-edges :after + ((window output-and-window-protocol-intermediary) + new-left new-top new-right new-bottom) + (declare (ignore new-left new-top new-right new-bottom)) + (let ((width (window-inside-width window))) + (setf (stream-default-text-margin window) width))) + +#-Silica +(defmethod bounding-rectangle-set-width :after + ((window output-and-window-protocol-intermediary) width height) + (declare (ignore width height)) + (let ((width (window-inside-width window))) + (setf (stream-default-text-margin window) width))) + + +;;; Methods for streams that are both output recording and extended input streams + +(defmethod invoke-with-output-recording-options :around + ((stream output-and-recording-protocol-intermediary) continuation record draw) + (let ((restore-p (and record + (not draw) + (not (stream-recording-p stream))))) + (multiple-value-bind (old-x old-y) + (when restore-p (stream-cursor-position* stream)) + (unwind-protect + (progn + (stream-close-text-output-record stream) + (call-next-method stream continuation record draw)) + (when restore-p (stream-set-cursor-position* stream old-x old-y)))))) + diff --git a/pre-silica/vertical-string.lisp b/pre-silica/vertical-string.lisp new file mode 100644 index 00000000..9d6326c6 --- /dev/null +++ b/pre-silica/vertical-string.lisp @@ -0,0 +1,45 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: vertical-string.lisp,v 1.4 91/03/26 12:49:04 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1988, 1989, 1990 International Lisp Associates. All rights reserved." + +;;; A utility for placing glyphs along a vertical path. Does not do any work yet +;;; to obtain a rotated font; but Bob said that could be a "future". +(defun draw-vertical-string* (stream string x y + &key (start 0) end + (align-x ':left) (align-y ':top)) + (when (null end) (setq end (length string))) + ;; What kind of font metrics do we get for the rotated font? Do we + ;; get "normal" metrics and then rotate them 90 degrees (i.e. use + ;; the char width for vertical alignment spacing) or use the font's + ;; height as the spacing increment? This currently just uses the + ;; height. + (let* ((y-span (stream-line-height stream)) + (x-span (stream-string-width stream "W")) + (count (- end start)) + (total-y-span (* count y-span)) + start-x start-y) + (ecase align-x + (:left (setq start-y y)) + (:right (setq start-y (+ y total-y-span))) + (:center (setq start-y (+ y (round total-y-span 2))))) + (ecase align-y + (:top (setq start-x x)) + (:bottom (setq start-x (- x x-span))) + (:center (setq start-x (- x (round x-span 2)))) + ;; --- just using "bottom" for now + (:baseline (setq start-x (- x x-span)))) + ;; draw string from bottom to top, assuming glyphs will be rotated + ;; 90 degrees left. + (dovector (char string :start start :end end) + (draw-character* stream char start-x start-y) + (decf start-y y-span)))) + +(defun draw-vertical-string (stream string point &key (start 0) end + (align-x ':left) (align-y ':top)) + (draw-vertical-string* stream string (point-x point) (point-y point) + :start start :end end + :align-x align-x :align-y align-y)) diff --git a/pre-silica/wheader.lisp b/pre-silica/wheader.lisp new file mode 100644 index 00000000..2cdd0a36 --- /dev/null +++ b/pre-silica/wheader.lisp @@ -0,0 +1,1634 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: wheader.lisp,v 1.4 91/03/26 12:49:06 cer Exp $ + +;;; "Translated" from \sys\include\windows.h + +(in-package :win) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +#|| +;;; OEMRESOURCE +(defconstant OBM_CLOSE 32767) +(defconstant OBM_SIZE 32766) +(defconstant OBM_UPARROW 32765) +(defconstant OBM_DNARROW 32764) +(defconstant OBM_RGARROW 32763) +(defconstant OBM_LFARROW 32762) +(defconstant OBM_BTSIZE 32761) +(defconstant OBM_CHECK 32760) +(defconstant OBM_CHECKBOXES 32759) +(defconstant OBM_BTNCORNERS 32758) +(defconstant OBM_REDUCE 32757) +(defconstant OBM_ZOOM 32756) +(defconstant OBM_RESTORE 32755) +(defconstant OCR_NORMAL 32512) +(defconstant OCR_IBEAM 32513) +(defconstant OCR_WAIT 32514) +(defconstant OCR_CROSS 32515) +(defconstant OCR_UP 32516) +(defconstant OCR_SIZE 32640) +(defconstant OCR_ICON 32641) +(defconstant OCR_SIZENWSE 32642) +(defconstant OCR_SIZENESW 32643) +(defconstant OCR_SIZEWE 32644) +(defconstant OCR_SIZENS 32645) +(defconstant OCR_SIZEALL 32646) + +(defconstant OIC_SAMPLE 32512) +(defconstant OIC_HAND 32513) +(defconstant OIC_QUES 32514) +(defconstant OIC_BANG 32515) +(defconstant OIC_NOTE 32516) +||# + +#| Scroll bar constants |# +(defconstant SB_HORZ 0) +(defconstant SB_VERT 1) +(defconstant SB_CTL 2) +(defconstant SB_BOTH 3) + +#| Scroll Commands |# + +(defconstant SB_LINEUP 0) +(defconstant SB_LINEDOWN 1) +(defconstant SB_PAGEUP 2) +(defconstant SB_PAGEDOWN 3) +(defconstant SB_THUMBPOSITION 4) +(defconstant SB_THUMBTRACK 5) +(defconstant SB_TOP 6) +(defconstant SB_BOTTOM 7) +(defconstant SB_ENDSCROLL 8) + + +#| ShowWindow commands |# + +(defconstant SW_HIDE 0) +(defconstant SW_SHOWNORMAL 1) +(defconstant SW_RESTORE 1) +(defconstant SW_NORMAL 1) +(defconstant SW_SHOWMINIMIZED 2) +(defconstant SW_SHOWMAXIMIZED 3) +(defconstant SW_MAXIMIZE 3) +(defconstant SW_SHOWNOACTIVATE 4) +(defconstant SW_SHOW 5) +(defconstant SW_MINIMIZE 6) +(defconstant SW_SHOWMINNOACTIVE 7) +(defconstant SW_SHOWNA 8) + +#|| +#| Old showwindow commands |# + +(defconstant HIDE_WINDOW 0) +(defconstant SHOW_OPENWINDOW 1) +(defconstant SHOW_ICONWINDOW 2) +(defconstant SHOW_FULLSCREEN 3) +(defconstant SHOW_OPENNOACTIVATE 4) + +#| identifiers for the WM_SHOWWINDOW message |# +(defconstant SW_PARENTCLOSING 1) +(defconstant SW_OTHERZOOM 2) +(defconstant SW_PARENTOPENING 3) +(defconstant SW_OTHERUNZOOM 4) + +#| flags for regions |# +(defconstant ERROR 0) +(defconstant NULLREGION 1) +(defconstant SIMPLEREGION 2) +(defconstant COMPLEXREGION 3) + +#| styles for CombineRgn |# +(defconstant RGN_AND 1) +(defconstant RGN_OR 2) +(defconstant RGN_XOR 3) +(defconstant RGN_DIFF 4) +(defconstant RGN_COPY 5) + +#| Virtual Keys, Standard Set |# + +(defconstant VK_LBUTTON #x01) +(defconstant VK_RBUTTON #x02) +(defconstant VK_CANCEL #x03) +(defconstant VK_MBUTTON #x04) #| NOT contiguous with L & RBUTTON |# +(defconstant VK_BACK #x08) +(defconstant VK_TAB #x09) +(defconstant VK_CLEAR #x0C) +(defconstant VK_RETURN #x0D) +(defconstant VK_SHIFT #x10) +(defconstant VK_CONTROL #x11) +(defconstant VK_MENU #x12) +(defconstant VK_PAUSE #x13) +(defconstant VK_CAPITAL #x14) +(defconstant VK_ESCAPE #x1B) +(defconstant VK_SPACE #x20) + +(defconstant VK_PRIOR #x21) +(defconstant VK_NEXT #x22) +(defconstant VK_END #x23) +(defconstant VK_HOME #x24) +(defconstant VK_LEFT #x25) +(defconstant VK_UP #x26) +(defconstant VK_RIGHT #x27) +(defconstant VK_DOWN #x28) + +#| VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z' |# +#| VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '0' |# + +(defconstant VK_SELECT #x29) +(defconstant VK_PRINT #x2A) +(defconstant VK_EXECUTE #x2B) +(defconstant VK_COPY #x2C) +(defconstant VK_INSERT #x2D) +(defconstant VK_DELETE #x2E) +(defconstant VK_HELP #x2F) + +(defconstant VK_NUMPAD0 #x60) +(defconstant VK_NUMPAD1 #x61) +(defconstant VK_NUMPAD2 #x62) +(defconstant VK_NUMPAD3 #x63) +(defconstant VK_NUMPAD4 #x64) +(defconstant VK_NUMPAD5 #x65) +(defconstant VK_NUMPAD6 #x66) +(defconstant VK_NUMPAD7 #x67) +(defconstant VK_NUMPAD8 #x68) +(defconstant VK_NUMPAD9 #x69) +(defconstant VK_MULTIPLY #x6A) +(defconstant VK_ADD #x6B) +(defconstant VK_SEPARATOR #x6C) +(defconstant VK_SUBTRACT #x6D) +(defconstant VK_DECIMAL #x6E) +(defconstant VK_DIVIDE #x6F) + +(defconstant VK_F1 #x70) +(defconstant VK_F2 #x71) +(defconstant VK_F3 #x72) +(defconstant VK_F4 #x73) +(defconstant VK_F5 #x74) +(defconstant VK_F6 #x75) +(defconstant VK_F7 #x76) +(defconstant VK_F8 #x77) +(defconstant VK_F9 #x78) +(defconstant VK_F10 #x79) +(defconstant VK_F11 #x7A) +(defconstant VK_F12 #x7B) +(defconstant VK_F13 #x7C) +(defconstant VK_F14 #x7D) +(defconstant VK_F15 #x7E) +(defconstant VK_F16 #x7F) + +(defconstant VK_NUMLOCK #x90) + + +#| SetWindowsHook codes |# +(defconstant WH_MSGFILTER -1) +(defconstant WH_JOURNALRECORD 0) +(defconstant WH_JOURNALPLAYBACK 1) +(defconstant WH_KEYBOARD 2) +(defconstant WH_GETMESSAGE 3) +(defconstant WH_CALLWNDPROC 4) +(defconstant WH_CBT 5) +(defconstant WH_SYSMSGFILTER 6) +(defconstant WH_WINDOWMGR 7) + +#| HC_* Hook Codes |# +(defconstant HC_LPLPFNNEXT -2) +(defconstant HC_LPFNNEXT -1) +(defconstant HC_ACTION 0) +(defconstant HC_GETNEXT 1) +(defconstant HC_SKIP 2) +(defconstant HC_NOREM 3) +(defconstant HC_NOREMOVE 3) + +#| CBT hook codes |# +(defconstant HCBT_MOVESIZE 0) +(defconstant HCBT_MINMAX 1) +(defconstant HCBT_QS 2) + +#| WH_MSGFILTER filter proc codes |# +(defconstant MSGF_DIALOGBOX 0) +(defconstant MSGF_MESSAGEBOX 1) +(defconstant MSGF_MENU 2) +(defconstant MSGF_MOVE 3) +(defconstant MSGF_SIZE 4) +(defconstant MSGF_SCROLLBAR 5) +(defconstant MSGF_NEXTWINDOW 6) + +#| Define window manager hook codes |# +(defconstant WC_INIT 1) +(defconstant WC_SWP 2) +(defconstant WC_DEFWINDOWPROC 3) +(defconstant WC_MINMAX 4) +(defconstant WC_MOVE 5) +(defconstant WC_SIZE 6) +(defconstant WC_DRAWCAPTION 7) +||# + +#| Binary raster ops |# +(defconstant R2_BLACK 1) #| 0 |# +(defconstant R2_NOTMERGEPEN 2) #| DPon |# +(defconstant R2_MASKNOTPEN 3) #| DPna |# +(defconstant R2_NOTCOPYPEN 4) #| PN |# +(defconstant R2_MASKPENNOT 5) #| PDna |# +(defconstant R2_NOT 6) #| Dn |# +(defconstant R2_XORPEN 7) #| DPx |# +(defconstant R2_NOTMASKPEN 8) #| DPan |# +(defconstant R2_MASKPEN 9) #| DPa |# +(defconstant R2_NOTXORPEN 10) #| DPxn |# +(defconstant R2_NOP 11) #| D |# +(defconstant R2_MERGENOTPEN 12) #| DPno |# +(defconstant R2_COPYPEN 13) #| P |# +(defconstant R2_MERGEPENNOT 14) #| PDno |# +(defconstant R2_MERGEPEN 15) #| DPo |# +(defconstant R2_WHITE 16) #| 1 |# + +#|| +#| Ternary raster operations |# +(defconstant SRCCOPY #x00CC0020) #| dest=source |# +(defconstant SRCPAINT #x00EE0086) #| dest=source OR dest |# +(defconstant SRCAND #x008800C6) #| dest=source AND dest |# +(defconstant SRCINVERT #x00660046) #| dest=source XOR dest |# +(defconstant SRCERASE #x00440328) #| dest=source AND (not dest ) |# +(defconstant NOTSRCCOPY #x00330008) #| dest=(not source) |# +(defconstant NOTSRCERASE #x001100A6) #| dest=(not source) AND (not dest) |# +(defconstant MERGECOPY #x00C000CA) #| dest=(source AND pattern) |# +(defconstant MERGEPAINT #x00BB0226) #| dest=(NOT source) OR dest |# +(defconstant PATCOPY #x00F00021) #| dest=pattern |# +(defconstant PATPAINT #x00FB0A09) #| dest=DPSnoo |# +(defconstant PATINVERT #x005A0049) #| dest=pattern XOR dest |# +(defconstant DSTINVERT #x00550009) #| dest=(not dest) |# +(defconstant BLACKNESS #x00000042) #| dest=BLACK |# +(defconstant WHITENESS #x00FF0062) #| dest=WHITE |# + +#| StretchBlt() modes |# +(defconstant BLACKONWHITE 1) +(defconstant WHITEONBLACK 2) +(defconstant COLORONCOLOR 3) + +#| PolyFill modes |# +(defconstant ALTERNATE 1) +(defconstant WINDING 2) + +#| text alignment options |# +(defconstant TA_UPDATECP 1) +(defconstant TA_NOUPDATECP 0) + +(defconstant TA_LEFT 0) +(defconstant TA_RIGHT 2) +(defconstant TA_CENTER 6) + +(defconstant TA_TOP 0) +(defconstant TA_BOTTOM 8) +(defconstant TA_BASELINE 24) + +(defconstant ETO_GRAYED 1) +(defconstant ETO_OPAQUE 2) +(defconstant ETO_CLIPPED 4) + + + +(defconstant ASPECT_FILTERING #x00000001) + +#| Meta file function numbers |# +(defconstant META_SETBKCOLOR #x0201) +(defconstant META_SETBKMODE #x0102) +(defconstant META_SETMAPMODE #x0103) +(defconstant META_SETROP2 #x0104) +(defconstant META_SETRELABS #x0105) +(defconstant META_SETPOLYFILLMODE #x0106) +(defconstant META_SETSTRETCHBLTMODE #x0107) +(defconstant META_SETTEXTCHAREXTRA #x0108) +(defconstant META_SETTEXTCOLOR #x0209) +(defconstant META_SETTEXTJUSTIFICATION #x020A) +(defconstant META_SETWINDOWORG #x020B) +(defconstant META_SETWINDOWEXT #x020C) +(defconstant META_SETVIEWPORTORG #x020D) +(defconstant META_SETVIEWPORTEXT #x020E) +(defconstant META_OFFSETWINDOWORG #x020F) +(defconstant META_SCALEWINDOWEXT #x0400) +(defconstant META_OFFSETVIEWPORTORG #x0211) +(defconstant META_SCALEVIEWPORTEXT #x0412) +(defconstant META_LINETO #x0213) +(defconstant META_MOVETO #x0214) +(defconstant META_EXCLUDECLIPRECT #x0415) +(defconstant META_INTERSECTCLIPRECT #x0416) +(defconstant META_ARC #x0817) +(defconstant META_ELLIPSE #x0418) +(defconstant META_FLOODFILL #x0419) +(defconstant META_PIE #x081A) +(defconstant META_RECTANGLE #x041B) +(defconstant META_ROUNDRECT #x061C) +(defconstant META_PATBLT #x061D) +(defconstant META_SAVEDC #x001E) +(defconstant META_SETPIXEL #x041F) +(defconstant META_OFFSETCLIPRGN #x0220) +(defconstant META_TEXTOUT #x0521) +(defconstant META_BITBLT #x0922) +(defconstant META_STRETCHBLT #x0B23) +(defconstant META_POLYGON #x0324) +(defconstant META_POLYLINE #x0325) +(defconstant META_ESCAPE #x0626) +(defconstant META_RESTOREDC #x0127) +(defconstant META_FILLREGION #x0228) +(defconstant META_FRAMEREGION #x0429) +(defconstant META_INVERTREGION #x012A) +(defconstant META_PAINTREGION #x012B) +(defconstant META_SELECTCLIPREGION #x012C) +(defconstant META_SELECTOBJECT #x012D) +(defconstant META_SETTEXTALIGN #x012E) +(defconstant META_DRAWTEXT #x062F) +(defconstant META_CHORD #x0630) +(defconstant META_CREATEBRUSH #x00F8) +(defconstant META_CREATEPATTERNBRUSH #x01F9) +(defconstant META_CREATEPENINDIRECT #x02FA) +(defconstant META_CREATEFONTINDIRECT #x02FB) +(defconstant META_CREATEBRUSHINDIRECT #x02FC) +(defconstant META_CREATEBITMAPINDIRECT #x02FD) +(defconstant META_CREATEBITMAP #x06FE) +(defconstant META_CREATEREGION #x06FF) + +#| GDI escapes |# +(defconstant NEWFRAME 1) +(defconstant ABORTDOC 2) +(defconstant NEXTBAND 3) +(defconstant SETCOLORTABLE 4) +(defconstant GETCOLORTABLE 5) +(defconstant FLUSHOUTPUT 6) +(defconstant DRAFTMODE 7) +(defconstant QUERYESCSUPPORT 8) +(defconstant SETABORTPROC 9) +(defconstant STARTDOC 10) +(defconstant ENDDOC 11) +(defconstant GETPHYSPAGESIZE 12) +(defconstant GETPRINTINGOFFSET 13) +(defconstant GETSCALINGFACTOR 14) +(defconstant MFCOMMENT 15) #| Metafile comment escape |# +(defconstant GETPENWIDTH 16) +(defconstant SETCOPYCOUNT 17) +(defconstant SELECTPAPERSOURCE 18) +(defconstant DEVICEDATA 19) +(defconstant PASSTHROUGH 19) +(defconstant GETTECHNOLGY 20) +(defconstant SETENDCAP 21) +(defconstant SETLINEJOIN 22) +(defconstant SETMITERLIMIT 23) +(defconstant BANDINFO 24) +(defconstant DRAWPATTERNRECT 25) +(defconstant GETVECTORPENSIZE 26) +(defconstant GETVECTORBRUSHSIZE 27) +(defconstant ENABLEDUPLEX 28) +(defconstant ENABLEMANUALFEED 29) + + + +(defconstant GETEXTENDEDTEXTMETRICS 256) +(defconstant GETEXTENTTABLE 257) +(defconstant GETPAIRKERNTABLE 258) +(defconstant GETTRACKKERNTABLE 259) + +(defconstant EXTTEXTOUT 512) + +(defconstant ENABLERELATIVEWIDTHS 768) +(defconstant ENABLEPAIRKERNING 769) +(defconstant SETKERNTRACK 770) +(defconstant STRETCHBLT 2048) + + +#| spooler error code |# +(defconstant SP_NOTREPORTED #x4000) #| set if GDI did not report error |# +(defconstant SP_ERROR -1) + #| general errors who know what went wrong |# +(defconstant SP_APPABORT -2) + #| app aborted the job - callback function returned false |# +(defconstant SP_USERABORT -3) + #| user aborted the job through spooler's front end |# +(defconstant SP_OUTOFDISK -4) #| not enough disk space to spool |# +(defconstant SP_OUTOFMEMORY -5) + +#| spooler WM_SPOOLERSTATUS wparm classes |# + +(defconstant PR_JOBSTATUS #x0000) + +#| Object definitions for GDI EnumObjects. |# +(defconstant OBJ_PEN 1) +(defconstant OBJ_BRUSH 2) + +#| Window field offsets for GetWindowLong & GetWindowWord |# +(defconstant GWL_WNDPROC -4) +(defconstant GWW_HINSTANCE -6) +(defconstant GWW_HWNDPARENT -8) +(defconstant GWW_HWNDTEXT -10) +(defconstant GWW_ID -12) +(defconstant GWL_STYLE -16) + +#| Class field offsets for GetClassLong & GetClassWord |# +(defconstant GCL_MENUNAME -8) +(defconstant GCW_HBRBACKGROUND -10) +(defconstant GCW_HCURSOR -12) +(defconstant GCW_HICON -14) +(defconstant GCW_HMODULE -16) +(defconstant GCW_CBWNDEXTRA -18) +(defconstant GCW_CBCLSEXTRA -20) +(defconstant GCL_WNDPROC -24) +(defconstant GCW_STYLE -26) + +#| ** Window Procedure Messages |# + +(defconstant WM_NULL #x0000) +(defconstant WM_CREATE #x0001) +(defconstant WM_DESTROY #x0002) +||# +(defconstant WM_MOVE #x0003) +#|| +(defconstant WM_SIZEWAIT #x0004) +||# +(defconstant WM_SIZE #x0005) +#|| +(defconstant WM_ACTIVATE #x0006) +(defconstant WM_SETFOCUS #x0007) +(defconstant WM_KILLFOCUS #x0008) +(defconstant WM_SETVISIBLE #x0009) +(defconstant WM_ENABLE #x000a) +(defconstant WM_SETREDRAW #x000b) +(defconstant WM_SETTEXT #x000c) +(defconstant WM_GETTEXT #x000d) +(defconstant WM_GETTEXTLENGTH #x000e) +||# +(defconstant WM_PAINT #x000f) +#|| +(defconstant WM_CLOSE #x0010) +(defconstant WM_QUERYENDSESSION #x0011) +(defconstant WM_QUIT #x0012) +(defconstant WM_QUERYOPEN #x0013) +(defconstant WM_ERASEBKGND #x0014) +(defconstant WM_SYSCOLORCHANGE #x0015) +(defconstant WM_ENDSESSION #x0016) +(defconstant WM_SYSTEMERROR #x0017) +(defconstant WM_SHOWWINDOW #x0018) +(defconstant WM_CTLCOLOR #x0019) +(defconstant WM_WININICHANGE #x001A) +(defconstant WM_DEVMODECHANGE #x001B) +(defconstant WM_ACTIVATEAPP #x001C) +(defconstant WM_FONTCHANGE #x001D) +(defconstant WM_TIMECHANGE #x001E) +(defconstant WM_CANCELMODE #x001F) +(defconstant WM_SETCURSOR #x0020) +(defconstant WM_MOUSEACTIVATE #x0021) +(defconstant WM_CHILDACTIVATE #x0022) +(defconstant WM_QUEUESYNC #x0023) +(defconstant WM_GETMINMAXINFO #x0024) +(defconstant WM_PAINTICON #x0026) +(defconstant WM_ICONERASEBKGND #x0027) +(defconstant WM_NEXTDLGCTL #x0028) +(defconstant WM_ALTTABACTIVE #x0029) #| for win386 only |# +(defconstant WM_SPOOLERSTATUS #x002A) + + +(defconstant WM_NCCREATE #x0081) +(defconstant WM_NCDESTROY #x0082) +(defconstant WM_NCCALCSIZE #x0083) +(defconstant WM_NCHITTEST #x0084) +(defconstant WM_NCPAINT #x0085) +(defconstant WM_NCACTIVATE #x0086) +(defconstant WM_GETDLGCODE #x0087) +(defconstant WM_SYNCPAINT #x0088) +(defconstant WM_SYNCTASK #x0089) + +(defconstant ST_BEGINSWP 0) +(defconstant ST_ENDSWP 1) + +(defconstant WM_NCMOUSEMOVE #x00a0) +(defconstant WM_NCLBUTTONDOWN #x00a1) +(defconstant WM_NCLBUTTONUP #x00a2) +(defconstant WM_NCLBUTTONDBLCLK #x00a3) +(defconstant WM_NCRBUTTONDOWN #x00a4) +(defconstant WM_NCRBUTTONUP #x00a5) +(defconstant WM_NCRBUTTONDBLCLK #x00a6) +(defconstant WM_NCMBUTTONDOWN #x00a7) +(defconstant WM_NCMBUTTONUP #x00a8) +(defconstant WM_NCMBUTTONDBLCLK #x00a9) + +#| WINWhere area codes |# +(defconstant HTERROR -2) +(defconstant HTTRANSPARENT -1) +(defconstant HTNOWHERE 0) +(defconstant HTCLIENT 1) +(defconstant HTCAPTION 2) +(defconstant HTSYSMENU 3) +(defconstant HTGROWBOX 4) +(defconstant HTSIZE HTGROWBOX) +(defconstant HTMENU 5) +(defconstant HTHSCROLL 6) +(defconstant HTVSCROLL 7) +(defconstant HTREDUCE 8) +(defconstant HTZOOM 9) +(defconstant HTLEFT 10) +(defconstant HTRIGHT 11) +(defconstant HTTOP 12) +(defconstant HTTOPLEFT 13) +(defconstant HTTOPRIGHT 14) +(defconstant HTBOTTOM 15) +(defconstant HTBOTTOMLEFT 16) +(defconstant HTBOTTOMRIGHT 17) +(defconstant HTSIZEFIRST HTLEFT) +(defconstant HTSIZELAST HTBOTTOMRIGHT) + +#| WM_MOUSEACTIVATE return codes |# +(defconstant MA_ACTIVATE 1) +(defconstant MA_ACTIVATEANDEAT 2) +(defconstant MA_NOACTIVATE 3) + +(defconstant WM_KEYFIRST #x0100) +(defconstant WM_KEYLAST #x0108) + +||# +(defconstant WM_KEYDOWN #x0100) +(defconstant WM_KEYUP #x0101) +(defconstant WM_CHAR #x0102) +(defconstant WM_SYSCHAR #x0106) +#|| +(defconstant WM_DEADCHAR #x0103) +(defconstant WM_SYSKEYDOWN #x0104) +(defconstant WM_SYSKEYUP #x0105) + +(defconstant WM_SYSDEADCHAR #x0107) +(defconstant WM_YOMICHAR #x0108) +(defconstant WM_CONVERTREQUEST #x010A) +(defconstant WM_CONVERTRESULT #x010B) + +(defconstant WM_INITDIALOG #x0110) +(defconstant WM_COMMAND #x0111) +(defconstant WM_SYSCOMMAND #x0112) +(defconstant WM_TIMER #x0113) +||# +(defconstant WM_HSCROLL #x0114) +(defconstant WM_VSCROLL #x0115) +#|| +(defconstant WM_INITMENU #x0116) +(defconstant WM_INITMENUPOPUP #x0117) +(defconstant WM_SYSTIMER #x0118) +(defconstant WM_MENUSELECT #x011f) +(defconstant WM_MENUCHAR #x0120) +(defconstant WM_ENTERIDLE #x0121) + + +(defconstant WM_MOUSEFIRST #x0200) +(defconstant WM_MOUSELAST #x0209) +||# +(defconstant WM_MOUSEMOVE #x0200) #| mouse related constants |# +(defconstant WM_LBUTTONDOWN #x0201) +(defconstant WM_LBUTTONUP #x0202) +(defconstant WM_LBUTTONDBLCLK #x0203) +(defconstant WM_RBUTTONDOWN #x0204) +(defconstant WM_RBUTTONUP #x0205) +(defconstant WM_RBUTTONDBLCLK #x0206) +(defconstant WM_MBUTTONDOWN #x0207) +(defconstant WM_MBUTTONUP #x0208) +(defconstant WM_MBUTTONDBLCLK #x0209) +#|| +(defconstant WM_KANJIFIRST #x0280) +(defconstant WM_KANJILAST #x029f) + +#| clipboard messages |# +(defconstant WM_CUT #x0300) +(defconstant WM_COPY #x0301) +(defconstant WM_PASTE #x0302) +(defconstant WM_CLEAR #x0303) +(defconstant WM_UNDO #x0304) +(defconstant WM_RENDERFORMAT #x0305) +(defconstant WM_RENDERALLFORMATS #x0306) +(defconstant WM_DESTROYCLIPBOARD #x0307) +(defconstant WM_DRAWCLIPBOARD #x0308) +(defconstant WM_PAINTCLIPBOARD #x0309) +(defconstant WM_VSCROLLCLIPBOARD #x030A) +(defconstant WM_SIZECLIPBOARD #x030B) +(defconstant WM_ASKCBFORMATNAME #x030C) +(defconstant WM_CHANGECBCHAIN #x030D) +(defconstant WM_HSCROLLCLIPBOARD #x030E) + +#| #x03f0 to #x03ff are reserved |# +#| private window messages start here |# +(defconstant WM_USER #x0400) +||# + +#| Size message commands |# +(defconstant SIZENORMAL 0) +(defconstant SIZEICONIC 1) +(defconstant SIZEFULLSCREEN 2) +(defconstant SIZEZOOMSHOW 3) +(defconstant SIZEZOOMHIDE 4) +#| Key state masks for mouse messages |# +(defconstant MK_LBUTTON #x0001) +(defconstant MK_RBUTTON #x0002) +(defconstant MK_SHIFT #x0004) +(defconstant MK_CONTROL #x0008) +(defconstant MK_MBUTTON #x0010) + + +#| Window styles |# +;;;*** Note: we've shifted these right by 4 bits to make them fixnums; +;;;*** see the definition of STORE-28BIT. +(defconstant WS_TILED #x0000000) +(defconstant WS_OVERLAPPED WS_TILED) +(defconstant WS_ICONICPOPUP #xc000000) +(defconstant WS_POPUP #x8000000) +(defconstant WS_CHILD #x4000000) +(defconstant WS_MINIMIZE #x2000000) +(defconstant WS_VISIBLE #x1000000) +(defconstant WS_DISABLED #x0800000) +(defconstant WS_CLIPSIBLINGS #x0400000) +(defconstant WS_CLIPCHILDREN #x0200000) +(defconstant WS_MAXIMIZE #x0100000) + +(defconstant WS_BORDER #x0080000) +(defconstant WS_CAPTION #x00c0000) +(defconstant WS_DLGFRAME #x0040000) +(defconstant WS_VSCROLL #x0020000) +(defconstant WS_HSCROLL #x0010000) +(defconstant WS_SYSMENU #x0008000) +(defconstant WS_SIZEBOX #x0004000) +(defconstant WS_THICKFRAME #x0004000) +(defconstant WS_GROUP #x0002000) +(defconstant WS_TABSTOP #x0001000) + +(defconstant WS_MINIMIZEBOX #x0002000) +(defconstant WS_MAXIMIZEBOX #x0001000) + +(defconstant WS_ICONIC WS_MINIMIZE) + +#| Class styles |# +(defconstant CS_VREDRAW #x0001) +(defconstant CS_HREDRAW #x0002) +(defconstant CS_KEYCVTWINDOW #x0004) +(defconstant CS_DBLCLKS #x0008) +(defconstant CS_OEMCHARS #x0010) +(defconstant CS_OWNDC #x0020) +(defconstant CS_CLASSDC #x0040) +(defconstant CS_PARENTDC #x0080) +(defconstant CS_NOKEYCVT #x0100) +(defconstant CS_SAVEBITS #x0800) +(defconstant CS_NOCLOSE #x0200) +(defconstant CS_BYTEALIGNCLIENT #x1000) +(defconstant CS_BYTEALIGNWINDOW #x2000) + +#| Shorthand for the common cases |# +(defconstant WS_TILEDWINDOW (logior WS_TILED WS_CAPTION WS_SYSMENU + WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX)) +(defconstant WS_OVERLAPPEDWINDOW WS_TILEDWINDOW) +(defconstant WS_POPUPWINDOW (logior WS_POPUP WS_BORDER WS_SYSMENU)) +(defconstant WS_CHILDWINDOW WS_CHILD) + +#|| +#| clipboard metafile picture structure |# + +#| predefined clipboard formats |# +(defconstant CF_TEXT 1) +(defconstant CF_BITMAP 2) +(defconstant CF_METAFILEPICT 3) +(defconstant CF_SYLK 4) +(defconstant CF_DIF 5) +(defconstant CF_TIFF 6) +(defconstant CF_OEMTEXT 7) + +(defconstant CF_OWNERDISPLAY #x80) #| owner display |# +(defconstant CF_DSPTEXT #x81) #| display text |# +(defconstant CF_DSPBITMAP #x82) #| display bitmap |# +(defconstant CF_DSPMETAFILEPICT #x83) #| display metafile |# + +#| Private clipboard format range |# +(defconstant CF_PRIVATEFIRST #x200) #| Anything in this range doesn't |# +(defconstant CF_PRIVATELAST #x2FF) #| get GlobalFree'd |# +(defconstant CF_GDIOBJFIRST #x300) #| Anything in this range gets |# +(defconstant CF_GDIOBJLAST #x3FF) #| DeleteObject'ed |# + +#| Logical font constants |# + +(defconstant OUT_DEFAULT_PRECIS 0) +(defconstant OUT_STRING_PRECIS 1) +(defconstant OUT_CHARACTER_PRECIS 2) +(defconstant OUT_STROKE_PRECIS 3) + +(defconstant CLIP_DEFAULT_PRECIS 0) +(defconstant CLIP_CHARACTER_PRECIS 1) +(defconstant CLIP_STROKE_PRECIS 2) + +(defconstant DEFAULT_QUALITY 0) +(defconstant DRAFT_QUALITY 1) +(defconstant PROOF_QUALITY 2) + +(defconstant DEFAULT_PITCH 0) +(defconstant FIXED_PITCH 1) +(defconstant VARIABLE_PITCH 2) + +(defconstant ANSI_CHARSET 0) +(defconstant SHIFTJIS_CHARSET 128) #| Kanji CharSet |# +(defconstant OEM_CHARSET 255) + +#| GDI font families. |# +(defconstant FF_DONTCARE 0) #| Don't care or don't know. |# +(defconstant FF_ROMAN 16) #| Variable stroke width, serifed. |# + #| Times Roman, Century Schoolbook, etc. |# +(defconstant FF_SWISS 32) #| Variable stroke width, sans-serifed. |# + #| Helvetica, Swiss, etc. |# +(defconstant FF_MODERN 48) #| Constant stroke width, serif or sans. |# + #| Pica, Elite, Courier, etc. |# +(defconstant FF_SCRIPT 64) #| Cursive, etc. |# +(defconstant FF_DECORATIVE 80) #| Old English, etc. |# + +#| Font weights lightest to darkest. |# +(defconstant FW_DONTCARE 0) +(defconstant FW_THIN 100) +(defconstant FW_EXTRALIGHT 200) +(defconstant FW_LIGHT 300) +(defconstant FW_NORMAL 400) +(defconstant FW_MEDIUM 500) +(defconstant FW_SEMIBOLD 600) +(defconstant FW_BOLD 700) +(defconstant FW_EXTRABOLD 800) +(defconstant FW_HEAVY 900) + +(defconstant FW_ULTRALIGHT FW_EXTRALIGHT) +(defconstant FW_REGULAR FW_NORMAL) +(defconstant FW_DEMIBOLD FW_SEMIBOLD) +(defconstant FW_ULTRABOLD FW_EXTRABOLD) +(defconstant FW_BLACK FW_HEAVY) + + +#| EnumFonts masks. |# +(defconstant RASTER_FONTTYPE #x0001) +(defconstant DEVICE_FONTTYPE #x0002) + +#| GDI rgb values packed into a dword |# + +#| +++ make these into Lisp macros! +(defconstant RGB(r,g,b) (( ((b) << 8 | (g)) << 8) | (r))) +(defconstant GetRValue(rgb) ((BYTE)(rgb))) +(defconstant GetGValue(rgb) ((BYTE)(((WORD)(rgb)) >> 8))) +(defconstant GetBValue(rgb) ((BYTE)((rgb)>>16))) +|# + +#| GDI Background Modes |# + +(defconstant TRANSPARENT 1) +(defconstant OPAQUE 2) + +#| GDI map modes |# +(defconstant MM_TEXT 1) +(defconstant MM_LOMETRIC 2) +(defconstant MM_HIMETRIC 3) +(defconstant MM_LOENGLISH 4) +(defconstant MM_HIENGLISH 5) +(defconstant MM_TWIPS 6) +(defconstant MM_ISOTROPIC 7) +(defconstant MM_ANISOTROPIC 8) + +#| GDI coordinate modes |# + +(defconstant ABSOLUTE 1) +(defconstant RELATIVE 2) +||# + +#| Stock Logical Objects |# +(defconstant WHITE_BRUSH 0) +(defconstant LTGRAY_BRUSH 1) +(defconstant GRAY_BRUSH 2) +(defconstant DKGRAY_BRUSH 3) +(defconstant BLACK_BRUSH 4) +(defconstant NULL_BRUSH 5) +(defconstant HOLLOW_BRUSH NULL_BRUSH) +(defconstant WHITE_PEN 6) +(defconstant BLACK_PEN 7) +(defconstant NULL_PEN 8) +(defconstant OEM_FIXED_FONT 10) +(defconstant ANSI_FIXED_FONT 11) +(defconstant ANSI_VAR_FONT 12) +(defconstant SYSTEM_FONT 13) +(defconstant DEVICEDEFAULT_FONT 14) + +#| GDI Brush Style definitions. |# + +(defconstant BS_SOLID 0) +(defconstant BS_NULL 1) +(defconstant BS_HOLLOW BS_NULL) +(defconstant BS_HATCHED 2) +(defconstant BS_PATTERN 3) +(defconstant BS_INDEXED 4) + +#| GDI Hatch Style definitions. |# + +(defconstant HS_HORIZONTAL 0) #| ----- |# +(defconstant HS_VERTICAL 1) #| ||||| |# +(defconstant HS_FDIAGONAL 2) #| ///// |# +(defconstant HS_BDIAGONAL 3) #| \\\\\ |# +(defconstant HS_CROSS 4) #| +++++ |# +(defconstant HS_DIAGCROSS 5) #| xxxxx |# + + +#| GDI Pen Style definitions |# +(defconstant PS_SOLID 0) #| solid pen |# +(defconstant PS_DASH 1) #| ------- |# +(defconstant PS_DOT 2) #| ....... |# +(defconstant PS_DASHDOT 3) #| _._._._ |# +(defconstant PS_DASHDOTDOT 4) #| _.._.._ |# +(defconstant PS_NULL 5) #| |# + +#|| +#| Device Parameters for GetDeviceCaps() |# + +(defconstant DRIVERVERSION 0) #| Device driver version |# +(defconstant TECHNOLOGY 2) #| Device classification |# +(defconstant HORZSIZE 4) #| Horizontal size in millimeters |# +(defconstant VERTSIZE 6) #| Vertical size in millimeters |# +(defconstant HORZRES 8) #| Horizontal width in pixels |# +(defconstant VERTRES 10) #| Vertical width in pixels |# +(defconstant BITSPIXEL 12) #| Number of bits per pixel |# +(defconstant PLANES 14) #| Number of planes |# +(defconstant NUMBRUSHES 16) #| Number of brushes the device has |# +(defconstant NUMPENS 18) #| Number of pens the device has |# +(defconstant NUMMARKERS 20) #| Number of markers the device has |# +(defconstant NUMFONTS 22) #| Number of fonts the device has |# +(defconstant NUMCOLORS 24) +(defconstant PDEVICESIZE 26) #| Size required for device descriptor |# +(defconstant CURVECAPS 28) #| Curves capabilities |# +(defconstant LINECAPS 30) #| Line capabilities |# +(defconstant POLYGONALCAPS 32) #| Polygonal capabilities |# +(defconstant TEXTCAPS 34) #| Text capabilities |# +(defconstant CLIPCAPS 36) #| Clipping capabilities |# +(defconstant RASTERCAPS 38) #| Bitblt capabilities |# +(defconstant ASPECTX 40) #| Length of the X leg |# +(defconstant ASPECTY 42) #| Length of the Y leg |# +(defconstant ASPECTXY 44) #| Length of the hypotenuse |# + +(defconstant LOGPIXELSX 88) #| Logical pixels/inch in X |# +(defconstant LOGPIXELSY 90) #| Logical pixels/inch in Y |# + +#| Device capability masks |# +#| Device Technologies |# + +(defconstant DT_PLOTTER 0) #| Vector plotter |# +(defconstant DT_RASDISPLAY 1) #| Raster display |# +(defconstant DT_RASPRINTER 2) #| Raster printer |# +(defconstant DT_RASCAMERA 3) #| Raster camera |# +(defconstant DT_CHARSTREAM 4) #| Character-stream, PLP |# +(defconstant DT_METAFILE 5) #| Metafile, VDM |# +(defconstant DT_DISPFILE 6) #| Display-file |# + +#| Curve Capabilities |# + +(defconstant CC_NONE 0) #| Curves not supported |# +(defconstant CC_CIRCLES 1) #| Can do circles |# +(defconstant CC_PIE 2) #| Can do pie wedges |# +(defconstant CC_CHORD 4) #| Can do chord arcs |# +(defconstant CC_ELLIPSES 8) #| Can do ellipese |# +(defconstant CC_WIDE 16) #| Can do wide lines |# +(defconstant CC_STYLED 32) #| Can do styled lines |# +(defconstant CC_WIDESTYLED 64) #| Can do wide styled lines|# +(defconstant CC_INTERIORS 128) #| Can do interiors |# + +#| Line Capabilities |# + +(defconstant LC_NONE 0) #| Lines not supported |# +(defconstant LC_POLYLINE 2) #| Can do polylines |# +(defconstant LC_MARKER 4) #| Can do markers |# +(defconstant LC_POLYMARKER 8) #| Can do polymarkers |# +(defconstant LC_WIDE 16) #| Can do wide lines |# +(defconstant LC_STYLED 32) #| Can do styled lines |# +(defconstant LC_WIDESTYLED 64) #| Can do wide styled lines|# +(defconstant LC_INTERIORS 128) #| Can do interiors |# + +#| Polygonal Capabilities |# + +(defconstant PC_NONE 0) #| Polygonals not supported|# +(defconstant PC_POLYGON 1) #| Can do polygons |# +(defconstant PC_RECTANGLE 2) #| Can do rectangles |# +(defconstant PC_TRAPEZOID 4) #| Can do trapezoids |# +(defconstant PC_SCANLINE 8) #| Can do scanlines |# +(defconstant PC_WIDE 16) #| Can do wide borders |# +(defconstant PC_STYLED 32) #| Can do styled borders |# +(defconstant PC_WIDESTYLED 64) #| Can do wide styled borders|# +(defconstant PC_INTERIORS 128) #| Can do interiors |# + +#| Polygonal Capabilities |# + +(defconstant CP_NONE 0) #| no clipping of Output |# +(defconstant CP_RECTANGLE 1) #| Output clipped to Rects |# + +#| Text Capabilities |# + +(defconstant TC_OP_CHARACTER #x0001) #| Can do OutputPrecision CHARACTER |# +(defconstant TC_OP_STROKE #x0002) #| Can do OutputPrecision STROKE |# +(defconstant TC_CP_STROKE #x0004) #| Can do ClipPrecision STROKE |# +(defconstant TC_CR_90 #x0008) #| Can do CharRotAbility 90 |# +(defconstant TC_CR_ANY #x0010) #| Can do CharRotAbility ANY |# +(defconstant TC_SF_X_YINDEP #x0020) #| " " ScaleFreedom X_YINDEPENDENT |# +(defconstant TC_SA_DOUBLE #x0040) #| Can do ScaleAbility DOUBLE |# +(defconstant TC_SA_INTEGER #x0080) #| Can do ScaleAbility INTEGER |# +(defconstant TC_SA_CONTIN #x0100) #| Can do ScaleAbility CONTINUOUS |# +(defconstant TC_EA_DOUBLE #x0200) #| Can do EmboldenAbility DOUBLE |# +(defconstant TC_IA_ABLE #x0400) #| Can do ItalisizeAbility ABLE |# +(defconstant TC_UA_ABLE #x0800) #| Can do UnderlineAbility ABLE |# +(defconstant TC_SO_ABLE #x1000) #| Can do StrikeOutAbility ABLE |# +(defconstant TC_RA_ABLE #x2000) #| Can do RasterFontAble ABLE |# +(defconstant TC_VA_ABLE #x4000) #| Can do VectorFontAble ABLE |# +(defconstant TC_RESERVED #x8000) #| Reserved. |# + +#| Raster Capabilities |# + +(defconstant RC_BITBLT 1) #| Can do standard non-stretching, non-inverting BLT. |# +(defconstant RC_BANDING 2) #| Device requires banding support |# +(defconstant RC_SCALING 4) #| Device requires scaling support |# +(defconstant RC_BITMAP64 8) #| Device can support >64K bitmap |# + + +#| PeekMessage options |# +(defconstant PM_REMOVE 1) +(defconstant PM_NOREMOVE 0) +(defconstant PM_NOYIELD 2) + +(defconstant CW_USEDEFAULT #x8000) #|used on both x and cx |# +||# + +#| SetWindowPos flags |# + +(defconstant SWP_NOSIZE #x01) +(defconstant SWP_NOMOVE #x02) +(defconstant SWP_NOZORDER #x04) +(defconstant SWP_NOREDRAW #x08) +(defconstant SWP_NOACTIVATE #x10) +(defconstant SWP_DRAWFRAME #x20) +(defconstant SWP_SHOWWINDOW #x40) +(defconstant SWP_HIDEWINDOW #x80) +(defconstant SWP_NOCOPYBITS #x0100) +(defconstant SWP_NOREPOSITION #x200) + +#|| +#| DrawFrame and associated defines |# +(defconstant DF_SHIFT0 #x0000) +(defconstant DF_SHIFT1 #x0001) +(defconstant DF_SHIFT2 #x0002) +(defconstant DF_SHIFT3 #x0003) +(defconstant DF_PATCOPY #x0000) +(defconstant DF_PATINVERT #x0004) + +#| +++ Fix these !!! +(defconstant DF_SCROLLBAR (COLOR_SCROLLBAR << 3)) +(defconstant DF_BACKGROUND (COLOR_BACKGROUND << 3)) +(defconstant DF_ACTIVECAPTION (COLOR_ACTIVECAPTION << 3)) +(defconstant DF_INACTIVECAPTION (COLOR_INACTIVECAPTION << 3)) +(defconstant DF_MENU (COLOR_MENU << 3)) +(defconstant DF_WINDOW (COLOR_WINDOW << 3)) +(defconstant DF_WINDOWFRAME (COLOR_WINDOWFRAME << 3)) +(defconstant DF_MENUTEXT (COLOR_MENUTEXT << 3)) +(defconstant DF_WINDOWTEXT (COLOR_WINDOWTEXT << 3)) +(defconstant DF_CAPTIONTEXT (COLOR_CAPTIONTEXT << 3)) +(defconstant DF_ACTIVEBORDER (COLOR_ACTIVEBORDER << 3)) +(defconstant DF_INACTIVEBORDER (COLOR_INACTIVEBORDER << 3)) +(defconstant DF_APPWORKSPACE (COLOR_APPWORKSPACE << 3)) +(defconstant DF_GRAY (DF_APPWORKSPACE + (1 << 3))) +|# + +#| DrawText format flags |# +(defconstant DT_LEFT #x00) +(defconstant DT_CENTER #x01) +(defconstant DT_RIGHT #x02) +(defconstant DT_TOP #x00) +(defconstant DT_VCENTER #x04) +(defconstant DT_BOTTOM #x08) +(defconstant DT_WORDBREAK #x10) +(defconstant DT_SINGLELINE #x20) +(defconstant DT_EXPANDTABS #x40) +(defconstant DT_TABSTOP #x80) +(defconstant DT_NOCLIP #x100) +(defconstant DT_EXTERNALLEADING #x200) +(defconstant DT_CALCRECT #x400) +(defconstant DT_NOPREFIX #x800) +(defconstant DT_INTERNAL #x1000) + +#| GetSystemMetrics codes |# +(defconstant SM_CXSCREEN 0) +(defconstant SM_CYSCREEN 1) +(defconstant SM_CXVSCROLL 2) +(defconstant SM_CYHSCROLL 3) +(defconstant SM_CYCAPTION 4) +(defconstant SM_CXBORDER 5) +(defconstant SM_CYBORDER 6) +(defconstant SM_CXDLGFRAME 7) +(defconstant SM_CYDLGFRAME 8) +(defconstant SM_CYVTHUMB 9) +(defconstant SM_CXHTHUMB 10) +(defconstant SM_CXICON 11) +(defconstant SM_CYICON 12) +(defconstant SM_CXCURSOR 13) +(defconstant SM_CYCURSOR 14) +(defconstant SM_CYMENU 15) +(defconstant SM_CXFULLSCREEN 16) +(defconstant SM_CYFULLSCREEN 17) +(defconstant SM_CYKANJIWINDOW 18) +(defconstant SM_MOUSEPRESENT 19) +(defconstant SM_CYVSCROLL 20) +(defconstant SM_CXHSCROLL 21) +(defconstant SM_DEBUG 22) +(defconstant SM_SWAPBUTTON 23) +(defconstant SM_RESERVED1 24) +(defconstant SM_RESERVED2 25) +(defconstant SM_RESERVED3 26) #| new additions since 2.0 |# +(defconstant SM_RESERVED4 27) +(defconstant SM_CXMIN 28) +(defconstant SM_CYMIN 29) +(defconstant SM_CXSIZE 30) +(defconstant SM_CYSIZE 31) +(defconstant SM_CXFRAME 32) +(defconstant SM_CYFRAME 33) +(defconstant SM_CXMINTRACK 34) +(defconstant SM_CYMINTRACK 35) +(defconstant SM_CMETRICS 36) + +#| MessageBox type flags |# +(defconstant MB_OK #x0000) +(defconstant MB_OKCANCEL #x0001) +(defconstant MB_ABORTRETRYIGNORE #x0002) +(defconstant MB_YESNOCANCEL #x0003) +(defconstant MB_YESNO #x0004) +(defconstant MB_RETRYCANCEL #x0005) + +(defconstant MB_ICONHAND #x0010) +(defconstant MB_ICONQUESTION #x0020) +(defconstant MB_ICONEXCLAMATION #x0030) +(defconstant MB_ICONASTERISK #x0040) + +(defconstant MB_DEFBUTTON1 #x0000) +(defconstant MB_DEFBUTTON2 #x0100) +(defconstant MB_DEFBUTTON3 #x0200) + +(defconstant MB_APPLMODAL #x0000) +(defconstant MB_SYSTEMMODAL #x1000) +(defconstant MB_NOFOCUS #x8000) +(defconstant MB_MISCMASK #xC000) +(defconstant MB_TYPEMASK #x000F) +(defconstant MB_ICONMASK #x00F0) +(defconstant MB_DEFMASK #x0F00) +(defconstant MB_MODEMASK #x3000) + +#| color type indices |# +#| for the WM_CTLCOLOR message |# +(defconstant CTLCOLOR_MSGBOX 0) +(defconstant CTLCOLOR_EDIT 1) +(defconstant CTLCOLOR_LISTBOX 2) +(defconstant CTLCOLOR_BTN 3) +(defconstant CTLCOLOR_DLG 4) +(defconstant CTLCOLOR_SCROLLBAR 5) +(defconstant CTLCOLOR_STATIC 6) +(defconstant CTLCOLOR_MAX 8) #| three bits max |# + +(defconstant COLOR_SCROLLBAR 0) +(defconstant COLOR_BACKGROUND 1) +(defconstant COLOR_ACTIVECAPTION 2) +(defconstant COLOR_INACTIVECAPTION 3) +(defconstant COLOR_MENU 4) +(defconstant COLOR_WINDOW 5) +(defconstant COLOR_WINDOWFRAME 6) +(defconstant COLOR_MENUTEXT 7) +(defconstant COLOR_WINDOWTEXT 8) +(defconstant COLOR_CAPTIONTEXT 9) +(defconstant COLOR_ACTIVEBORDER 10) +(defconstant COLOR_INACTIVEBORDER 11) +(defconstant COLOR_APPWORKSPACE 12) + +(defconstant CP_GETBEEP 1) +(defconstant CP_SETBEEP 2) +(defconstant CP_GETMOUSE 3) +(defconstant CP_SETMOUSE 4) +(defconstant CP_GETBORDER 5) +(defconstant CP_SETBORDER 6) +(defconstant CP_TIMEOUTS 7) +(defconstant CP_KANJIMENU 8) + +#| Flags for GetTempFileName |# +(defconstant TF_FORCEDRIVE #x80) #| Forces use of current dir of |# + #| passed drive |# +#| Flags for OpenFile |# +(defconstant OF_REOPEN #x8000) +(defconstant OF_EXIST #x4000) +(defconstant OF_PROMPT #x2000) +(defconstant OF_CREATE #x1000) +(defconstant OF_CANCEL #x0800) +(defconstant OF_VERIFY #x0400) +(defconstant OF_DELETE #x0200) +(defconstant OF_PARSE #x0100) + +(defconstant OF_READ 0) +(defconstant OF_WRITE 1) +(defconstant OF_READWRITE 2) + +#| Interface to global memory manager |# +(defconstant GMEM_FIXED #x0000) +(defconstant GMEM_MOVEABLE #x0002) +(defconstant GMEM_NOCOMPACT #x0010) +(defconstant GMEM_NODISCARD #x0020) +(defconstant GMEM_ZEROINIT #x0040) +(defconstant GMEM_MODIFY #x0080) +(defconstant GMEM_DISCARDABLE #x0F00) +(defconstant GHND (logior GMEM_MOVEABLE GMEM_ZEROINIT)) +(defconstant GPTR (logior GMEM_FIXED GMEM_ZEROINIT)) +(defconstant GMEM_SHARE #x2000) +(defconstant GMEM_DDESHARE #x2000) +(defconstant GMEM_NOT_BANKED #x1000) +(defconstant GMEM_NOTIFY #x4000) +(defconstant GMEM_LOWER GMEM_NOT_BANKED) + +#| Flags returned by GlobalFlags (in addition to GMEM_DISCARDABLE) |# +(defconstant GMEM_DISCARDED #x4000) +(defconstant GMEM_SWAPPED #x8000) +(defconstant GMEM_LOCKCOUNT #x00FF) + +#| Interface to local memory manager |# + +(defconstant LMEM_FIXED #x0000) +(defconstant LMEM_MOVEABLE #x0002) +(defconstant LMEM_NOCOMPACT #x0010) +(defconstant LMEM_NODISCARD #x0020) +(defconstant LMEM_ZEROINIT #x0040) +(defconstant LMEM_MODIFY #x0080) +(defconstant LMEM_DISCARDABLE #x0F00) +(defconstant LHND (logior LMEM_MOVEABLE LMEM_ZEROINIT)) +(defconstant LPTR (logior LMEM_FIXED LMEM_ZEROINIT)) +(defconstant NONZEROLHND LMEM_MOVEABLE) +(defconstant NONZEROLPTR LMEM_FIXED) + +(defconstant LNOTIFY_OUTOFMEM 0) +(defconstant LNOTIFY_MOVE 1) +(defconstant LNOTIFY_DISCARD 2) + +#| Flags returned by LocalFlags (in addition to LMEM_DISCARDABLE) |# +(defconstant LMEM_DISCARDED #x4000) +(defconstant LMEM_LOCKCOUNT #x00FF) + +#| Predefined resource types |# +(defconstant RT_CURSOR 1) +(defconstant RT_BITMAP 2) +(defconstant RT_ICON 3) +(defconstant RT_MENU 4) +(defconstant RT_DIALOG 5) +(defconstant RT_STRING 6) +(defconstant RT_FONTDIR 7) +(defconstant RT_FONT 8) +(defconstant RT_ACCELERATOR 9) +(defconstant RT_RCDATA 10) + +#| GetWindow() and constants |# +(defconstant GW_HWNDFIRST 0) +(defconstant GW_HWNDLAST 1) +(defconstant GW_HWNDNEXT 2) +(defconstant GW_HWNDPREV 3) +(defconstant GW_OWNER 4) +(defconstant GW_CHILD 5) + +#| Menu flags for Add/Check/EnableMenuItem |# +(defconstant MF_CHANGE #x0080) +(defconstant MF_INSERT #x0000) +(defconstant MF_APPEND #x0100) +(defconstant MF_DELETE #x0200) +(defconstant MF_BYPOSITION #x0400) +(defconstant MF_SEPARATOR #x0800) +(defconstant MF_REMOVE #x1000) +(defconstant MF_BYCOMMAND #x0000) +(defconstant MF_GRAYED #x0001) +(defconstant MF_DISABLED #x0002) +(defconstant MF_ENABLED #x0000) +(defconstant MF_CHECKED #x0008) +(defconstant MF_UNCHECKED #x0000) +(defconstant MF_BITMAP #x0004) +(defconstant MF_STRING #x0000) +(defconstant MF_POPUP #x0010) +(defconstant MF_MENUBARBREAK #x0020) +(defconstant MF_MENUBREAK #x0040) +(defconstant MF_HILITE #x0080) +(defconstant MF_UNHILITE #x0000) +(defconstant MF_HELP #x4000) +(defconstant MF_SYSMENU #x2000) +(defconstant MF_MOUSESELECT #x8000) + +#| System Menu Command Values |# +(defconstant SC_SIZE #xF000) +(defconstant SC_MOVE #xF010) +(defconstant SC_MINIMIZE #xF020) +(defconstant SC_MAXIMIZE #xF030) +(defconstant SC_NEXTWINDOW #xF040) +(defconstant SC_PREVWINDOW #xF050) +(defconstant SC_CLOSE #xF060) +(defconstant SC_VSCROLL #xF070) +(defconstant SC_HSCROLL #xF080) +(defconstant SC_MOUSEMENU #xF090) +(defconstant SC_KEYMENU #xF100) +(defconstant SC_ARRANGE #xF110) +(defconstant SC_RESTORE #xF120) +(defconstant SC_ICON SC_MINIMIZE) +(defconstant SC_ZOOM SC_MAXIMIZE) +||# + +#| Standard cursor IDs |# +(defconstant IDC_ARROW 32512) +(defconstant IDC_IBEAM 32513) +(defconstant IDC_WAIT 32514) +(defconstant IDC_CROSS 32515) +(defconstant IDC_UPARROW 32516) +(defconstant IDC_SIZE 32640) +(defconstant IDC_ICON 32641) +(defconstant IDC_SIZENWSE 32642) +(defconstant IDC_SIZENESW 32643) +(defconstant IDC_SIZEWE 32644) +(defconstant IDC_SIZENS 32645) + +#|| +#| Standard icon IDs |# +(defconstant IDI_APPLICATION 32512) +(defconstant IDI_HAND 32513) +(defconstant IDI_QUESTION 32514) +(defconstant IDI_EXCLAMATION 32515) +(defconstant IDI_ASTERISK 32516) + +(defconstant CP_HWND 0) +(defconstant CP_OPEN 1) +(defconstant CP_DIRECT 2) + +#| VK from the keyboard driver |# +(defconstant VK_KANA #x15) +(defconstant VK_ROMAJI #x16) +(defconstant VK_ZENKAKU #x17) +(defconstant VK_HIRAGANA #x18) +(defconstant VK_KANJI #x19) + +#| VK to send to Applications |# +(defconstant VK_CONVERT #x1C) +(defconstant VK_NONCONVERT #x1D) +(defconstant VK_ACCEPT #x1E) +(defconstant VK_MODECHANGE #x1F) + +#| Conversion function numbers |# +(defconstant KNJ_START #x01) +(defconstant KNJ_END #x02) +(defconstant KNJ_QUERY #x03) + +(defconstant KNJ_LEARN_MODE #x10) +(defconstant KNJ_GETMODE #x11) +(defconstant KNJ_SETMODE #x12) + +(defconstant KNJ_CODECONVERT #x20) +(defconstant KNJ_CONVERT #x21) +(defconstant KNJ_NEXT #x22) +(defconstant KNJ_PREVIOUS #x23) +(defconstant KNJ_ACCEPT #x24) + +(defconstant KNJ_LEARN #x30) +(defconstant KNJ_REGISTER #x31) +(defconstant KNJ_REMOVE #x32) +(defconstant KNJ_CHANGE_UDIC #x33) + +#| note: DEFAULT= 0 + JIS1 = 1 + JIS2 = 2 + SJIS2 = 3 + JIS1KATAKANA = 4 + SJIS2HIRAGANA = 5 + SJIS2KATAKANA = 6 + OEM = F +|# + +(defconstant KNJ_JIS1toJIS1KATAKANA #x14) +(defconstant KNJ_JIS1toSJIS2 #x13) +(defconstant KNJ_JIS1toSJIS2HIRAGANA #x15) +(defconstant KNJ_JIS1toSJIS2KATAKANA #x16) +(defconstant KNJ_JIS1toDEFAULT #x10) +(defconstant KNJ_JIS1toSJIS2OEM #x1F) +(defconstant KNJ_JIS2toSJIS2 #x23) +(defconstant KNJ_SJIS2toJIS2 #x32) + +#| see KNJ_GETMODE for definition |# +(defconstant KNJ_MD_ALPHA #x01) +(defconstant KNJ_MD_HIRAGANA #x02) +(defconstant KNJ_MD_HALF #x04) +(defconstant KNJ_MD_JIS #x08) +(defconstant KNJ_MD_SPECIAL #x10) + +#| conversion modes, low word of lParam when VK_CONVERT is sent to the app |# +(defconstant KNJ_CVT_NEXT #x01) +(defconstant KNJ_CVT_PREV #x02) +(defconstant KNJ_CVT_KATAKANA #x03) +(defconstant KNJ_CVT_HIRAGANA #x04) +(defconstant KNJ_CVT_JIS1 #x05) +(defconstant KNJ_CVT_SJIS2 #x06) +(defconstant KNJ_CVT_DEFAULT #x07) +(defconstant KNJ_CVT_TYPED #x08) + +#| Conventional dialog box and message box command IDs |# +(defconstant IDOK 1) +(defconstant IDCANCEL 2) +(defconstant IDABORT 3) +(defconstant IDRETRY 4) +(defconstant IDIGNORE 5) +(defconstant IDYES 6) +(defconstant IDNO 7) + +#| Control manager structures & definitions |# +#| Edit control class stuff |# + +#| styles |# +(defconstant ES_LEFT 0) +(defconstant ES_CENTER 1) +(defconstant ES_RIGHT 2) +(defconstant ES_MULTILINE 4) +(defconstant ES_AUTOVSCROLL 64) +(defconstant ES_AUTOHSCROLL 128) +(defconstant ES_NOHIDESEL 256) + +#| notification codes |# +(defconstant EN_SETFOCUS #x0100) +(defconstant EN_KILLFOCUS #x0200) +(defconstant EN_CHANGE #x0300) +(defconstant EN_UPDATE #x0400) +(defconstant EN_ERRSPACE #x0500) +(defconstant EN_HSCROLL #x0601) +(defconstant EN_VSCROLL #x0602) + +#| control messages: |# +#| +++ Fix these! +(defconstant EM_GETSEL (WM_USER+0) +(defconstant EM_SETSEL (WM_USER+1) +(defconstant EM_GETRECT (WM_USER+2) +(defconstant EM_SETRECT (WM_USER+3) +(defconstant EM_SETRECTNP (WM_USER+4) +(defconstant EM_SCROLL (WM_USER+5) +(defconstant EM_LINESCROLL (WM_USER+6) +(defconstant EM_GETMODIFY (WM_USER+8) +(defconstant EM_SETMODIFY (WM_USER+9) +(defconstant EM_GETLINECOUNT (WM_USER+10) +(defconstant EM_LINEINDEX (WM_USER+11) +(defconstant EM_SETHANDLE (WM_USER+12) +(defconstant EM_GETHANDLE (WM_USER+13) +(defconstant EM_GETTHUMB (WM_USER+14) +(defconstant EM_LINELENGTH (WM_USER+17) +(defconstant EM_REPLACESEL (WM_USER+18) +(defconstant EM_SETFONT (WM_USER+19) +(defconstant EM_GETLINE (WM_USER+20) +(defconstant EM_LIMITTEXT (WM_USER+21) +(defconstant EM_CANUNDO (WM_USER+22) +(defconstant EM_UNDO (WM_USER+23) +(defconstant EM_FMTLINES (WM_USER+24) +(defconstant EM_LINEFROMCHAR (WM_USER+25) +(defconstant EM_SETWORDBREAK (WM_USER+26) +|# + +#| button control styles |# +(defconstant BS_PUSHBUTTON 0) +(defconstant BS_DEFPUSHBUTTON 1) +(defconstant BS_CHECKBOX 2) +(defconstant BS_AUTOCHECKBOX 3) +(defconstant BS_RADIOBUTTON 4) +(defconstant BS_3STATE 5) +(defconstant BS_AUTO3STATE 6) +(defconstant BS_GROUPBOX 7) +(defconstant BS_USERBUTTON 8) +(defconstant BS_AUTORADIOBUTTON 9) +(defconstant BS_PUSHBOX 10) +(defconstant BS_LEFTTEXT #x20) + +#| user button notification codes |# +(defconstant BN_CLICKED 0) +(defconstant BN_PAINT 1) +(defconstant BN_HILITE 2) +(defconstant BN_UNHILITE 3) +(defconstant BN_DISABLE 4) +(defconstant BN_DOUBLECLICKED 5) + +#| control messages |# +#| +++ Fix these! +(defconstant BM_GETCHECK WM_USER+0) +(defconstant BM_SETCHECK WM_USER+1) +(defconstant BM_GETSTATE WM_USER+2) +(defconstant BM_SETSTATE WM_USER+3) +(defconstant BM_SETSTYLE WM_USER+4) +|# + +#| Static control constants |# + +(defconstant SS_LEFT 0) +(defconstant SS_CENTER 1) +(defconstant SS_RIGHT 2) +(defconstant SS_ICON 3) +(defconstant SS_BLACKRECT 4) +(defconstant SS_GRAYRECT 5) +(defconstant SS_WHITERECT 6) +(defconstant SS_BLACKFRAME 7) +(defconstant SS_GRAYFRAME 8) +(defconstant SS_WHITEFRAME 9) +(defconstant SS_USERITEM 10) +(defconstant SS_SIMPLE 11) +(defconstant SS_NOPREFIX 128) #| #x80 - don't do "&" character translation |# + +#| Dialog style bits |# +(defconstant DS_ABSALIGN #x000000001) +(defconstant DS_SYSMODAL #x000000002) +(defconstant DS_LOCALEDIT #x000000020) #| Edit items get Local storage. |# + +#| +++ Fix these! +(defconstant DM_GETDEFID (WM_USER+0) +(defconstant DM_SETDEFID (WM_USER+1) +|# +(defconstant DC_HASDEFID #x534B) + +#| Dialog codes (returned by WM_GETDLGCODE message): |# + +(defconstant DLGC_WANTARROWS #x01) #| control wants arrow keys |# +(defconstant DLGC_WANTTAB #x02) #| control wants tab keys |# +(defconstant DLGC_WANTALLKEYS #x04) #| control wants all keys |# +(defconstant DLGC_WANTMESSAGE #x04) #| pass message to control |# +(defconstant DLGC_HASSETSEL #x08) #| understands EM_SETSEL message |# +(defconstant DLGC_DEFPUSHBUTTON #x10) #| Default pushbutton |# +(defconstant DLGC_UNDEFPUSHBUTTON #x20) #| Non-default pushbutton |# +(defconstant DLGC_RADIOBUTTON #x40) #| radio button |# +(defconstant DLGC_WANTCHARS #x80) #| Want WM_CHAR messages |# +(defconstant DLGC_STATIC #x100) #| Static item: don't include |# +(defconstant DLGC_BUTTON #x2000) #| Button item: can be checked |# + +(defconstant LB_CTLCODE 0) + +#| Listbox control return values |# +(defconstant LB_OKAY 0) +(defconstant LB_ERR -1) +(defconstant LB_ERRSPACE -2) + +#| listbox notification codes |# +(defconstant LBN_ERRSPACE -2) +(defconstant LBN_SELCHANGE 1) +(defconstant LBN_DBLCLK 2) + +#| listbox messages |# +#| +++ Fix these! +(defconstant LB_ADDSTRING (1+WM_USER) +(defconstant LB_INSERTSTRING (2+WM_USER) +(defconstant LB_DELETESTRING (3+WM_USER) +(defconstant LB_RESETCONTENT (5+WM_USER) +(defconstant LB_SETSEL (6+WM_USER) +(defconstant LB_SETCURSEL (7+WM_USER) +(defconstant LB_GETSEL (8+WM_USER) +(defconstant LB_GETCURSEL (9+WM_USER) +(defconstant LB_GETTEXT (10+WM_USER) +(defconstant LB_GETTEXTLEN (11+WM_USER) +(defconstant LB_GETCOUNT (12+WM_USER) +(defconstant LB_SELECTSTRING (13+WM_USER) +(defconstant LB_DIR (14+WM_USER) +(defconstant LB_GETTOPINDEX (15+WM_USER) +(defconstant LB_MSGMAX (16+WM_USER) +|# + +#| listbox style bits |# +(defconstant LBS_NOTIFY #x0001) +(defconstant LBS_SORT #x0002) +(defconstant LBS_NOREDRAW #x0004) +(defconstant LBS_MULTIPLESEL #x0008) +(defconstant LBS_STANDARD (logior LBS_NOTIFY LBS_SORT + WS_VSCROLL WS_BORDER)) + +#| scroll bar styles |# +(defconstant SBS_HORZ #x0000) +(defconstant SBS_VERT #x0001) +(defconstant SBS_TOPALIGN #x0002) +(defconstant SBS_LEFTALIGN #x0002) +(defconstant SBS_BOTTOMALIGN #x0004) +(defconstant SBS_RIGHTALIGN #x0004) +(defconstant SBS_SIZEBOXTOPLEFTALIGN #x0002) +(defconstant SBS_SIZEBOXBOTTOMRIGHTALIGN #x0004) +(defconstant SBS_SIZEBOX #x0008) + +#| constants used to specify return condition for WaitSoundState |# + +(defconstant S_QUEUEEMPTY 0) +(defconstant S_THRESHOLD 1) +(defconstant S_ALLTHRESHOLD 2) + +#| constants used to specify accent mode |# + +(defconstant S_NORMAL 0) +(defconstant S_LEGATO 1) +(defconstant S_STACCATO 2) + +#| constants used to specify source in SetSoundNoise |# +(defconstant S_PERIOD512 0) #| freq = N/512 high pitch, less coarse hiss |# +(defconstant S_PERIOD1024 1) #| freq = N/1024 |# +(defconstant S_PERIOD2048 2) #| freq = N/2048 low pitch, more coarse hiss |# +(defconstant S_PERIODVOICE 3) #| source is frequency from voice channel (3) |# + +(defconstant S_WHITE512 4) #| freq = N/512 high pitch, less coarse hiss |# +(defconstant S_WHITE1024 5) #| freq = N/1024 |# +(defconstant S_WHITE2048 6) #| freq = N/2048 low pitch, more coarse hiss |# +(defconstant S_WHITEVOICE 7) #| source is frequency from voice channel (3) |# + +(defconstant S_SERDVNA -1) #| device not available |# +(defconstant S_SEROFM -2) #| out of memory |# +(defconstant S_SERMACT -3) #| music active |# +(defconstant S_SERQFUL -4) #| queue full |# +(defconstant S_SERBDNT -5) #| invalid note |# +(defconstant S_SERDLN -6) #| invalid note length |# +(defconstant S_SERDCC -7) #| invalid note count |# +(defconstant S_SERDTP -8) #| invalid tempo |# +(defconstant S_SERDVL -9) #| invalid volume |# +(defconstant S_SERDMD -10) #| invalid mode |# +(defconstant S_SERDSH -11) #| invalid shape |# +(defconstant S_SERDPT -12) #| invalid pitch |# +(defconstant S_SERDFQ -13) #| invalid frequency |# +(defconstant S_SERDDR -14) #| invalid duration |# +(defconstant S_SERDSR -15) #| invalid source |# +(defconstant S_SERDST -16) #| invalid state |# + + +#| +** +** dcb field definitions. +** +|# + +(defconstant NOPARITY 0) +(defconstant ODDPARITY 1) +(defconstant EVENPARITY 2) +(defconstant MARKPARITY 3) +(defconstant SPACEPARITY 4) + +(defconstant ONESTOPBIT 0) +(defconstant ONE5STOPBITS 1) +(defconstant TWOSTOPBITS 2) + +(defconstant IGNORE 0) #| Ignore signal |# +(defconstant INFINITE #xFFFF) #| Infinite timeout |# + + + +#| +** +** Comm Device Driver Error Bits. +** +|# + +(defconstant CE_RXOVER #x0001) #| Receive Queue overflow |# +(defconstant CE_OVERRUN #x0002) #| Receive Overrun Error |# +(defconstant CE_RXPARITY #x0004) #| Receive Parity Error |# +(defconstant CE_FRAME #x0008) #| Receive Framing error |# +(defconstant CE_BREAK #x0010) #| Break Detected |# +(defconstant CE_CTSTO #x0020) #| CTS Timeout |# +(defconstant CE_DSRTO #x0040) #| DSR Timeout |# +(defconstant CE_RLSDTO #x0080) #| RLSD Timeout |# +(defconstant CE_TXFULL #x0100) #| TX Queue is full |# +(defconstant CE_PTO #x0200) #| LPTx Timeout |# +(defconstant CE_IOE #x0400) #| LPTx I/O Error |# +(defconstant CE_DNS #x0800) #| LPTx Device not selected |# +(defconstant CE_OOP #x1000) #| LPTx Out-Of-Paper |# +(defconstant CE_MODE #x8000) #| Requested mode unsupported |# + + +#|************************************************************************ +** +** Initialization Error Codes +** +************************************************************************|# + +(defconstant IE_BADID -1) #| Invalid or unsupported id |# +(defconstant IE_OPEN -2) #| Device Already Open |# +(defconstant IE_NOPEN -3) #| Device Not Open |# +(defconstant IE_MEMORY -4) #| Unable to allocate queues |# +(defconstant IE_DEFAULT -5) #| Error in default parameters |# +(defconstant IE_HARDWARE -10) #| Hardware Not Present |# +(defconstant IE_BYTESIZE -11) #| Illegal Byte Size |# +(defconstant IE_BAUDRATE -12) #| Unsupported BaudRate |# + + +#|************************************************************************ +** +** Event Definitions +** +************************************************************************|# + +(defconstant EV_RXCHAR #x0001) #| Any Character received |# +(defconstant EV_RXFLAG #x0002) #| Received certain character |# +(defconstant EV_TXEMPTY #x0004) #| Transmitt Queue Empty |# +(defconstant EV_CTS #x0008) #| CTS changed state |# +(defconstant EV_DSR #x0010) #| DSR changed state |# +(defconstant EV_RLSD #x0020) #| RLSD changed state |# +(defconstant EV_BREAK #x0040) #| BREAK received |# +(defconstant EV_ERR #x0080) #| Line status error occurred |# +(defconstant EV_RING #x0100) #| Ring signal detected |# +(defconstant EV_PERR #x0200) #| Printer error occured |# + + +#|************************************************************************ +** +** Escape Functions +** +************************************************************************|# + +(defconstant SETXOFF 1) #| Simulate XOFF received |# +(defconstant SETXON 2) #| Simulate XON received |# +(defconstant SETRTS 3) #| Set RTS high |# +(defconstant CLRRTS 4) #| Set RTS low |# +(defconstant SETDTR 5) #| Set DTR high |# +(defconstant CLRDTR 6) #| Set DTR low |# +(defconstant RESETDEV 7) #| Reset device if possible |# +||# diff --git a/pre-silica/window-protocol.lisp b/pre-silica/window-protocol.lisp new file mode 100644 index 00000000..2d074130 --- /dev/null +++ b/pre-silica/window-protocol.lisp @@ -0,0 +1,500 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: window-protocol.lisp,v 1.7 91/03/29 18:01:14 cer Exp $ + +(in-package :clim-internals) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +;;; So we don't process operations twice, once when *we* process it, +;;; again when the implementation layer says "Hey, guess what?" +(defvar *synchronous-window-operation-being-processed* nil) + +(define-stream-protocol-class window ()) + +#-Silica +(progn + +(defclass window-mixin + (standard-bounding-rectangle window) + ((parent :accessor window-parent :initarg :parent) + (children :accessor window-children :initform nil) + ;; --- better term than console? + (console :accessor window-console :initarg :console) + (name :accessor window-name :initarg :name) + (label :accessor window-label :initarg :label) + (depth :accessor window-depth :initarg :depth) ;is this bits-per-pixel? + (viewport :accessor window-viewport :initarg :viewport) + (update-region :accessor window-update-region :initform nil) + (visibility :accessor window-visibility :initform nil) + #+Ignore + (input-process :accessor window-input-process) + (inside-width-cache :initform nil)) + (:default-initargs :parent nil :console nil :name nil :label nil)) + +;; Prevent using the instance-ref instructions on these, since they +;; usually have :BEFORE/:AFTER qualifiers on the SETF methods that will +;; cause the instance-ref instructions to take a slow trap. +#+(or Genera Minima) +(progn + (declaim (notinline window-label (setf window-label))) + (declaim (notinline window-visibility (setf window-visibility)))) + +;;; Runs :AROUND so that edges will be set up by primary method and :AFTER method +;;; for the specific implementation. +(defmethod initialize-instance :around ((window window-mixin) + &key parent scroll-bars borders) + ;; All ports accept these standard window decoration options + ;; Accept them here for the benefit of warn-if-pane-descriptions-invalid + scroll-bars borders ;ignored, declare ignore doesn't work here + (call-next-method) + (when parent + (push window (window-children parent))) + (with-slots (viewport left top right bottom) window + ;; Make initial viewport the same size as the window rooted at the origin. + ;; (window edges are in parent's coordinate system, while viewport edges are in window's) + + ;; --- Is this right? At least it works... + (multiple-value-bind (width height) (window-inside-size window) + (setf viewport (make-bounding-rectangle 0 0 width height)) + ; --- cross protocol violation, but we're moving to Silica anyway + (when (extended-output-stream-p window) + (setf (stream-default-text-margin window) + width))))) + +;;; WINDOW-ERASE-VIEWPORT req'd +;;; WINDOW-STACK-ON-TOP req'd +;;; WINDOW-STACK-ON-BOTTOM req'd +;;; COPY-AREA req'd + +(defmethod window-refresh :around ((stream window-mixin)) + (when (window-drawing-possible stream) + (call-next-method))) + +(defmethod window-stream-stack-on-top :around ((window window-mixin)) + (let ((*synchronous-window-operation-being-processed* t)) + (call-next-method))) + +(defmethod bounding-rectangle-set-edges :around ((window window-mixin) left top right bottom) + (declare (ignore left top right bottom)) + (let ((*synchronous-window-operation-being-processed* T)) + (call-next-method))) + +(defmethod bounding-rectangle-set-position* :around ((window window-mixin) nx ny) + (declare (ignore nx ny)) + (let ((*synchronous-window-operation-being-processed* t)) + (call-next-method))) + +(defmethod bounding-rectangle-set-size :around ((window window-mixin) width height) + (declare (ignore width height)) + (let ((*synchronous-window-operation-being-processed* t)) + (call-next-method))) + +;;; These methods are needed for hooks on other mixins to work. +(defmethod window-viewport-position* ((window window-mixin)) + (with-slots (viewport) window + (bounding-rectangle-position* viewport))) + +(defmethod window-set-viewport-position* ((window window-mixin) x y) + (with-slots (viewport) window + (bounding-rectangle-set-position* viewport x y))) + +(defmethod window-with-zero-viewport-position + ((window window-mixin) continuation) + ;;--- should be on window-and-graphics-intermediary?? + ;; Margin components should not respect the stream transform + (letf-globally (((medium-transformation window) +identity-transformation+)) + (let ((viewport (window-viewport window))) + (multiple-value-bind (x y) (bounding-rectangle-position* viewport) + (unwind-protect + (progn (bounding-rectangle-set-position* viewport 0 0) + (funcall continuation)) + (bounding-rectangle-set-position* viewport x y)))))) + +) ;#-Silica + +(defmethod window-clear ((window #-Silica window-mixin #+Silica t)) + #-Silica + (window-erase-viewport window) + (when (extended-output-stream-p window) ;can we assume this? + (stream-set-cursor-position* window 0 0) + (setf (stream-baseline window) 0 + (stream-current-line-height window) 0)) + #-Silica + (bounding-rectangle-set-position* (window-viewport window) 0 0) + #+Ignore + (window-set-viewport-position* window 0 0)) + +;;; Basically a hook for other mixins. +(defmethod window-refresh ((window #-Silica window-mixin #+Silica t)) + (window-erase-viewport window)) + +(defmethod window-expose ((window #-Silica window-mixin #+Silica t)) + (setf (window-visibility window) t) + #-Silica + (window-stack-on-top window)) + + +;;; --- This needs to be on window-output... +;(defmethod window-fresh-page ((stream window-mixin)) +; (multiple-value-call #'window-set-viewport-position* +; window +; (window-stream-cursor-position* stream))) +; + +(defun window-size-viewport-to-fit (window) + (multiple-value-bind (w h) (window-inside-size window) + (multiple-value-bind (lm rm tm bm) (window-margins window) + (declare (ignore lm tm)) + (bounding-rectangle-set-size (window-viewport window) (- w rm) (- h bm))))) + + +;;; Coordinate translations + +#-Silica +(progn + +;;;--- FIXNUM stuff + +;;; The true interfaces: +;;; WINDOW-TO-SCREEN-COORDINATES Window-X Window-Y -> Screen-X Screen-Y +(defmethod window-to-screen-coordinates ((window window-mixin) x y) + (declare (type coordinate x y)) + (multiple-value-bind (dx dy) (window-to-screen-coordinate-translations window) + (declare (type coordinate dx dy)) + (values (the fixnum (+ x dx)) (the fixnum (+ y dy))))) + +(defmethod screen-to-window-coordinates ((window window-mixin) x y) + (declare (type coordinate x y)) + (multiple-value-bind (dx dy) (window-to-screen-coordinate-translations window) + (declare (type coordinate dx dy)) + (values (the fixnum (- x dx)) (the fixnum (- y dy))))) + +;;; An internal routine +(defmethod window-to-screen-coordinate-translations ((window window-mixin)) + (with-slots (left top viewport parent) window + (declare (fixnum left top)) + (multiple-value-bind (left-translation top-translation) (window-margins window) + (declare (fixnum left-translation top-translation)) + (setq left-translation (the fixnum (+ left-translation left))) + (setq top-translation (the fixnum (+ top-translation top))) + (when parent + (multiple-value-bind (parent-left parent-top) + (window-to-screen-coordinate-translations parent) + (declare (fixnum parent-left parent-top)) + (setq left-translation (the fixnum (+ left-translation parent-left))) + (setq top-translation (the fixnum (+ top-translation parent-top))))) + (when viewport + (multiple-value-bind (viewport-left viewport-top) + (bounding-rectangle-position* viewport) + (declare (fixnum viewport-left viewport-top)) + (setq left-translation (the fixnum (- left-translation viewport-left))) + (setq top-translation (the fixnum (- top-translation viewport-top))))) + (values left-translation top-translation)))) + +(defmethod drawing-surface-to-viewport-coordinates ((window window-mixin) dsx dsy) + (declare (fixnum dsx dsy)) + (multiple-value-bind (vx vy) (window-viewport-position* window) + (declare (fixnum vx vy)) + (multiple-value-bind (ml mt) (window-margins window) + (declare (fixnum ml mt)) + (values (the fixnum (+ (the fixnum (- dsx vx)) ml)) + (the fixnum (+ (the fixnum (- dsy vy)) mt)))))) + +(defmethod viewport-to-drawing-surface-coordinates ((window window-mixin) x y) + (declare (fixnum x y)) + (multiple-value-bind (vx vy) (window-viewport-position* window) + (declare (fixnum vx vy)) + (multiple-value-bind (ml mt) (window-margins window) + (declare (fixnum ml mt)) + (values (the fixnum (- (the fixnum (+ x vx)) ml)) + (the fixnum (- (the fixnum (+ y vy)) mt)))))) + +) ;#-Silica + +#-Silica +(progn + +;;;--- FIXNUM stuff +;;; Hmm. +(defmethod bounding-rectangle-set-edges :after ((window window-mixin) left top right bottom) + (declare (ignore left top right bottom)) + (window-size-viewport-to-fit window) + (setf (slot-value window 'inside-width-cache) nil)) + +(defmethod bounding-rectangle-set-size :after ((window window-mixin) width height) + (declare (ignore width height)) + (window-size-viewport-to-fit window) + (setf (slot-value window 'inside-width-cache) nil)) + +(defmethod window-inside-size ((window window-mixin)) + (multiple-value-bind (left top right bottom) (window-inside-edges window) + (declare (fixnum left top right bottom)) + (values (the fixnum (- right left)) (the fixnum (- bottom top))))) + +(defmethod window-inside-edges ((stream window-mixin)) + (multiple-value-bind (lm tm rm bm) (host-window-margins stream) + (declare (fixnum lm tm rm bm)) + (with-bounding-rectangle* (left top right bottom) stream + (values (the fixnum (+ left lm)) (the fixnum (+ top tm)) + (the fixnum (- right rm)) (the fixnum (- bottom bm)))))) + +(defmethod window-set-inside-edges ((stream window-mixin) + new-left new-top new-right new-bottom) + (declare (fixnum new-left new-top new-right new-bottom)) + (multiple-value-bind (lm tm rm bm) (host-window-margins stream) + (declare (fixnum lm tm rm bm)) + (bounding-rectangle-set-edges + stream + (the fixnum (- new-left lm)) (the fixnum (- new-top tm)) + (the fixnum (+ new-right rm)) (the fixnum (+ new-bottom bm))))) + +;; the port needs to define host-window-margins + +(defmethod window-set-inside-size ((window window-mixin) new-width new-height) + (multiple-value-bind (left top) (window-inside-edges window) + (window-set-inside-edges window left top (+ left new-width) (+ top new-height)))) + +(defmacro define-window-inside-methods (useless &aux code) + (labels ((emit-methods (vars primitive) + (do* ((i 0 (1+ i)) + (names vars (cdr names))) + ((null names)) + (emit-method (method-name (car names) 'window-inside) i vars primitive))) + (method-name (name prefix) (fintern "~A-~A" prefix name)) + (emit-method (name nth-value vars called-method) + (push `(defmethod ,name ((window window-mixin)) + ,(if (= nth-value 0) `(values (,called-method window)) + `(multiple-value-bind ,(subseq vars 0 (1+ nth-value)) + (,called-method window) + (declare (ignore ,@(subseq vars 0 nth-value))) + ,(nth nth-value vars)))) + code))) + (emit-methods '(left top right bottom) 'window-inside-edges) + (emit-methods '(width height) 'window-inside-size)) + `(define-group ,useless define-window-inside-methods ,@(nreverse code))) + +(define-window-inside-methods methods) + +(defmethod window-inside-width :around ((window window-mixin)) + (with-slots (inside-width-cache) window + (or inside-width-cache + (setf inside-width-cache (call-next-method))))) + +) ;#-Silica + +#+Genera +(defgeneric stream-compatible-inside-size (window) + (:selector :inside-size)) + +#+Genera +(defmethod stream-compatible-inside-size ((window window-mixin)) + (bounding-rectangle-size (window-viewport window))) + +#+Genera +(defgeneric stream-compatible-visible-cursorpos-limits (window &optional unit) + (:selector :visible-cursorpos-limits)) + +#+Genera +(defmethod stream-compatible-visible-cursorpos-limits ((window window-mixin) + &optional (unit ':pixel)) + (with-bounding-rectangle* (left top right bottom) (window-viewport window) + (ecase unit + (:pixel (values left top right bottom)) + (:character (let ((char-width (stream-character-width window #\M)) + (line-height (stream-line-height window))) + (values (floor left char-width) (floor top line-height) + (floor right char-width) (floor bottom line-height))))))) + +#+Genera +(defgeneric stream-compatible-size-in-characters (window) + (:selector :size-in-characters)) + +#+Genera +(defmethod stream-compatible-size-in-characters ((window window-mixin)) + (with-bounding-rectangle* (left top right bottom) (window-viewport window) + (let ((char-width (stream-character-width window #\M)) + (line-height (stream-line-height window))) + (values (floor (- right left) char-width) + (floor (- bottom top) line-height))))) + +#-Silica +(progn + +(defmethod window-label-size ((window window-mixin) &optional (label (window-label window))) + (declare (ignore label)) + ;; default method returns nothing. + (values 0 0)) + +(defmethod window-note-size-or-position-change ((window window-mixin) + new-left new-top new-right new-bottom) + ;; + (with-slots (left top right bottom) window + (setf left new-left) + (setf top new-top) + (setf right new-right) + (setf bottom new-bottom)) + ;; for the time being, make the viewport fill the window + (window-size-viewport-to-fit window)) + +;;;--- FIXNUM stuff + +;;; Offset from root +(defun window-offset (stream) + (let ((x-offset 0) + (y-offset 0)) + (declare (fixnum x-offset y-offset)) + (do ((s stream (window-parent s))) + ((null s) nil) + (multiple-value-bind (x y) (bounding-rectangle-position* s) + (declare (fixnum x y)) + (multiple-value-bind (ml mt) (host-window-margins s) + (declare (fixnum ml mt)) + (setq x-offset (the fixnum (+ x-offset x ml))) + (setq y-offset (the fixnum (+ y-offset y mt)))))) + (values x-offset y-offset))) + +) ;#-Silica + +;; This is called by OUTPUT-RECORDING-MIXIN's whopper on set-viewport-position*. +;; It shifts a region of the "host screen" that's visible to some other visible +;; location. It does NOT do any cleaning up after itself. It does not side-effect +;; the output history of the window. It calls COPY-AREA whose contract is to +;; do the above, the whole above, and nothing but the above. +(defmethod window-shift-visible-region ((window #-Silica window-mixin #+Silica t) + old-left old-top old-right old-bottom + new-left new-top new-right new-bottom) + (declare (type coordinate new-left new-top new-right new-bottom)) + (declare (ignore old-right old-bottom new-right new-bottom)) + (let ((delta-x (- old-left new-left)) + (delta-y (- old-top new-top))) + (multiple-value-bind (stream-width stream-height) + #-Silica (window-inside-size window) + #+Silica (bounding-rectangle-size (pane-viewport-region window)) + (declare (type coordinate stream-width stream-height)) + (let (from-x from-y) + (cond ((and (>= delta-x 0) + (>= delta-y 0)) + ;; shifting down and to the right + (setq from-x 0 + from-y 0)) + ((and (>= delta-x 0) + (<= delta-y 0)) + ;; shifting up and to the right + (setq from-x 0 + from-y (abs delta-y))) + ((>= delta-y 0) + ;; shifting down and to the left + (setq from-x (abs delta-x) + from-y 0)) + (t + ;; shifting up and to the left + (setq from-x (abs delta-x) + from-y (abs delta-y)))) + (let ((width (- stream-width (abs delta-x))) + (height (- stream-height (abs delta-y)))) + (multiple-value-bind (ml mt) + #+Silica (values 0 0) + #-Silica (window-margins window) + (declare (type coordinate ml mt)) + (translate-fixnum-positions ml mt from-x from-y) + (copy-area window + from-x from-y + (+ from-x width) (+ from-y height) + (+ from-x delta-x) (+ from-y delta-y)))))))) + + +#+Silica +(defun window-viewport-position* (stream) + (bounding-rectangle-position* (pane-viewport-region stream))) + +#+Silica +(defun window-set-viewport-position* (stream x y) + (scroll-extent stream :x x :y y)) + + + + +#+Silica +(defun-inline window-parent (window) + (sheet-parent window)) + +(defun window-root (window) + (do ((win window (window-parent win))) + ((null (window-parent win)) + win))) + +(defun window-top-level-window (window) + (do* ((win window parent) + (parent (window-parent win) parent-parent) + (parent-parent (if parent (window-parent parent) T) (window-parent parent))) + ((null parent-parent) win) + (when (eql parent-parent T) (return nil)))) + +#-Silica +(progn + +;;; Make sure cursor is always visible. +(defmethod stream-advance-cursor-line :after ((stream output-and-window-protocol-intermediary)) + (stream-ensure-cursor-visible stream)) + +(defmethod stream-set-cursor-position* :after ((stream output-and-window-protocol-intermediary) + new-x new-y) + (stream-ensure-cursor-visible stream new-x new-y)) + +(defmethod stream-set-cursor-position*-internal :after + ((stream output-and-window-protocol-intermediary) new-x new-y) + (stream-ensure-cursor-visible stream new-x new-y)) + +(defmethod stream-ensure-cursor-visible ((stream output-and-window-protocol-intermediary) + &optional cx cy) + (when (or (not (output-recording-stream-p stream)) + (stream-drawing-p stream)) + (unless cy (multiple-value-setq (cx cy) (stream-cursor-position* stream))) + (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream) + (let ((new-x nil) + (new-y nil)) + ;; Vertical case + (unless (eql (stream-end-of-page-action stream) ':allow) + (incf cy (min (- vbottom vtop) + (* 2 (stream-line-height stream)))) + (unless (<= vtop cy vbottom) + (setf new-y (max 0 (- cy (- vbottom vtop)))))) + ;; Horizontal case + (unless (eql (stream-end-of-line-action stream) ':allow) + (unless (<= vleft cx vright) + (setf new-x (max 0 (- cx (- vright vleft + (* 4 (stream-character-width stream #\W)))))))) + (when (or new-x new-y) + (window-set-viewport-position* stream (or new-x vleft) (or new-y vtop))))))) + +) ;#-Silica + +;;; rudimentary audio + +#-Silica +(progn + +(defmethod window-beep ((stream t)) + #+Genera (scl:beep) + #+CCL-2 (ccl::ed-beep) + nil) + +(defun beep (&optional (stream *standard-output*)) + (window-beep stream)) + +(defun whistle (&key (direction ':down)) + #-Genera (declare (ignore direction)) + #+Genera (compiler:inhibit-style-warnings (dbg:whistle :direction direction)) + #-Genera (dotimes (i 3) (beep))) + +) ;#-Silica + +#+Silica +(defun beep (&optional (stream *standard-output*)) + (silica::sheet-beep stream)) + + +(defun window-inside-size (w) + (bounding-rectangle-size (pane-viewport-region w))) diff --git a/pre-silica/windows.lisp b/pre-silica/windows.lisp new file mode 100644 index 00000000..94121a5b --- /dev/null +++ b/pre-silica/windows.lisp @@ -0,0 +1,1334 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: windows.lisp,v 1.4 91/03/26 12:49:09 cer Exp $ + +(in-package :win) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(export '(START-WINDOWS)) +;;; Buffer commands (MUST BE KEPT CONSISTENT WITH VMWIN.H!) + +;;; Takes a one byte argument and sets the state. This command is currently +;;; only processed by the windows side +(defconstant *VM-BCOM-SET-STATE* #x01) +(defconstant *VM-STATE-INITIALIZED* #x01) +(defconstant *VM-STATE-INPUT-WAIT* #x02) +(defconstant *VM-STATE-RUN* #x03) +(defconstant *VM-STATE-STOP* #x04) +(defconstant *VM-STATE-BREAK* #x05) + +;;; Sends 2 byte wParam from windows message, which is the character code. +;;; When sent to windows, 2 byte character to output +(defconstant *VM-BCOM-CHARACTER* #x02) + +;;; Get ready to received menu items. No args. +(defconstant *VM-BCOM-START-MENU* #x03) + +;;; Add a menu item. Bytes are a null-terminated string. +(defconstant *VM-BCOM-MENU-ITEM* #x04) + +;;; Expose and get a selection from the menu +(defconstant *VM-BCOM-MENU-CHOOSE* #x05) + +;;; Returned to VM. The menu item number selected in first byte, second +;;; byte 0 if single or 1 if double click +(defconstant *VM-BCOM-MENU-SELECTION* #x06) + +(defconstant *VM-BCOM-MENU-CAPTION* #x07) + +;;; Get pathname from user, blocks until response is generated +(defconstant *VM-BCOM-GET-PATHNAME* #x08) + +;;; Draws a line, 4 16 bit args are X0, Y0, X1, Y1 +(defconstant *VM-BCOM-DRAW-LINE* #x09) + +;;; Draws a character at a particular point, args are char, X, Y +(defconstant *VM-BCOM-DRAW-CHAR* #x0A) + +;;; Returned to VM: A two-byte short window handle (HWND) +(defconstant *VM-BCOM-WINDOW-VALUE* #x0B) + +;;; Returned to VM: A two-byte short device context handle (HDC) +(defconstant *VM-BCOM-DC-VALUE* #x0C) + +;;; Returned to VM: A two-byte short handle (HANDLE) +(defconstant *VM-BCOM-HANDLE-VALUE* #x0D) + +;;; Returned to VM: A many-byte text metric structure +(defconstant *VM-BCOM-METRIC-VALUE* #x0E) + +;;; Returned to VM: An eight-byte rectangle structure +(defconstant *VM-BCOM-RECT-VALUE* #x0F) + +;;; Messages below are generic interface functions. +;;; The functions that interpret them are in winfe.c. +(defconstant *VM-BCOM-MOVE-TO* #x10) +(defconstant *VM-BCOM-LINE-TO* #x11) +(defconstant *VM-BCOM-TEXT-OUT* #x12) +(defconstant *VM-BCOM-ELLIPSE* #x13) +(defconstant *VM-BCOM-CREATE-WINDOW* #x14) +(defconstant *VM-BCOM-SHOW-WINDOW* #x15) +(defconstant *VM-BCOM-DESTROY-WINDOW* #x16) +(defconstant *VM-BCOM-SCROLL-DC* #x17) +(defconstant *VM-BCOM-GET-DC* #x18) +(defconstant *VM-BCOM-RELEASE-DC* #x19) +(defconstant *VM-BCOM-ARC* #x1A) +(defconstant *VM-BCOM-CREATE-PEN* #x1B) +(defconstant *VM-BCOM-CREATE-SOLID-BRUSH* #x1C) +(defconstant *VM-BCOM-CREATE-PATTERN-BRUSH* #x1D) +(defconstant *VM-BCOM-SET-BRUSH-ORG* #x1E) +(defconstant *VM-BCOM-GET-STOCK-OBJECT* #x1F) +(defconstant *VM-BCOM-SELECT-OBJECT* #x20) +(defconstant *VM-BCOM-GET-TERM-WINDOW* #x21) +(defconstant *VM-BCOM-BEGIN-PAINT* #x22) +(defconstant *VM-BCOM-END-PAINT* #x23) +(defconstant *VM-BCOM-STRING-ARG* #x24) +(defconstant *VM-BCOM-PIE* #x25) +(defconstant *VM-BCOM-RECTANGLE* #x26) +(defconstant *VM-BCOM-DELETE-OBJECT* #x27) +(defconstant *VM-BCOM-GET-ROP2* #x28) +(defconstant *VM-BCOM-SET-ROP2* #x29) +(defconstant *VM-BCOM-POLYGON* #x2A) +(defconstant *VM-BCOM-VANILLA-EVENT* #x2B) +(defconstant *VM-BCOM-SET-FOCUS* #x2C) +(defconstant *VM-BCOM-MOVE-WINDOW* #x2D) +(defconstant *VM-BCOM-CREATE-BITMAP* #x2E) +(defconstant *VM-BCOM-CREATE-FONT* #x2F) +(defconstant *VM-BCOM-GET-TEXT-METRICS* #x30) +(defconstant *VM-BCOM-WINDOW-FROM-POINT* #x31) +(defconstant *VM-BCOM-GET-UPDATE-RECT* #x32) +(defconstant *VM-BCOM-PAINT-EVENT* #x33) +(defconstant *VM-BCOM-SELECT-BRUSH* #x34) +(defconstant *VM-BCOM-SELECT-PEN* #x35) +(defconstant *VM-BCOM-SELECT-BITMAP* #x36) +(defconstant *VM-BCOM-SELECT-FONT* #x37) +(defconstant *VM-BCOM-SELECT-REGION* #x38) +(defconstant *VM-BCOM-SET-TEXT-COLOR* #x39) +(defconstant *VM-BCOM-BEEP* #x3A) +(defconstant *VM-BCOM-SET-SCROLL-POSITION* #x3B) +(defconstant *VM-BCOM-SET-BACKGROUND-COLOR* #x3C) +(defconstant *VM-BCOM-GET-CLIENT-RECTANGLE* #x3D) +(defconstant *VM-BCOM-GET-TEXT-EXTENT* #x3E) +(defconstant *VM-BCOM-CREATE-FONT-INDIRECT* #x3F) +(defconstant *VM-BCOM-SET-ERASE-BRUSH* #x40) +(defconstant *VM-BCOM-GET-SCREEN-SIZE* #x41) +(defconstant *VM-BCOM-SCREEN-SIZE* #x42) +(defconstant *VM-BCOM-DRAW-BITMAP* #x43) +(defconstant *VM-BCOM-SET-POINTER-POS* #x44) +(defconstant *VM-BCOM-GET-POINTER-POS* #x45) +(defconstant *VM-BCOM-POINTER-POSITION* #x45) +(defconstant *VM-BCOM-READ-BITMAP* #x46) +(defconstant *VM-BCOM-LOADCURSOR* #x47) +(defconstant *VM-BCOM-SET-MOUSE-CURSOR* #x48) +(defconstant *VM-BCOM-SET-WINDOW-TEXT* #x49) +(defconstant *VM-BCOM-SET-WINDOW-POS* #x4A) +(defconstant *VM-BCOM-IS-ICONIC* #x4B) +(defconstant *VM-BCOM-GET-WINDOW-RECTANGLE* #x4C) +(defconstant *VM-BCOM-SHOW-SCROLL-BAR* #x4D) +(defconstant *VM-BCOM-POLYLINE* #x4E) +(defconstant *VM-BCOM-NOTIFY-USER* #x4F) +(defconstant *VM-BCOM-IS-WINDOW-VISIBLE* #x50) +(defconstant *VM-BCOM-WINDOW-EXEC* #x51) +(defconstant *VM-BCOM-CHANGE-DIR* #x52) +(defconstant *VM-BCOM-GET-FOCUS* #x53) +(defconstant *VM-BCOM-SHOW-CARET* #x54) +(defconstant *VM-BCOM-SET-CARET-POS* #x55) +(defconstant *VM-BCOM-HIDE-CARET* #x56) +(defconstant *VM-BCOM-LOAD-BITMAP* #x57) +(defconstant *VM-BCOM-NONCLIENT-PAINT* #x59) + +;;; Unique ID: sets the unique ID for the next command that requests a +;;; return value, or the return unique ID. A UID is one byte. +(defconstant *VM-BCOM-UID* #xFC) + +;;; Special long message operator +(defconstant *VM-BCOM-LONG-MESSAGE* #xFD) + +;;; General cancellation +(defconstant *VM-BCOM-CANCEL* #xFE) + +;;; No message available now +(defconstant *VM-BCOM-NULL* #xFF) + + +(defvar *windows-enabled* nil) +(defvar *stream*) +(defvar *old-terminal-io*) +(defvar *win2-com* nil) +(defvar *win3-com* nil) +(defvar *winfe-exe* "winfe.exe") ; "\\clim\\winfe.exe" +(defvar *win-com-file* "WIN.COM") +(defvar *win-cloe-file* "CLOEWIN.COM") + +(defvar *windows-standard-mode* t) +(defvar *standard-stub* "STDSTUB.EXE") + +(defvar *win-3-binary* '#x(EB 09 58 57 00 00 00 00 + 00 00 00 E8 71 06 BB 3C)) + +;;; Patches to WIN.COM V3. Must be in numerical order by offset. +(defvar *win-3-patches* '#x((8C4 5D 00) (8E6 40 01))) + +;;; Find the windows .COM file in the specified directory. If it's +;;; a Windows 3 .COM and not converted for CLOE, do the conversion. +(defun find-windows-com-1 (dir) + (setf dir (concatenate 'string dir "\\")) + (let ((cloe-pn (merge-pathnames dir *win-cloe-file*)) + (win-pn (merge-pathnames dir *win-com-file*))) + ;; First try for the converted file + (when (probe-file cloe-pn) + (return-from find-windows-com-1 + (values (namestring cloe-pn) t t))) + (unless (probe-file win-pn) + (return-from find-windows-com-1 nil)) + (with-open-file (win-com win-pn :direction :input + :element-type '(unsigned-byte 8)) + (when win-com + (let ((first-bytes (loop repeat 16 collect (read-byte win-com)))) + (cond ((not (equal first-bytes *win-3-binary*)) + (return-from find-windows-com-1 + (namestring win-pn) nil nil)) + (t + ;; Have a windows 3 .COM, patch it + (with-open-file (cloe-com cloe-pn :direction :output + :element-type '(unsigned-byte 8)) + (dolist (n first-bytes) (write-byte n cloe-com)) + (format t "~&Creating ~A..." (namestring cloe-pn)) + (loop with patches = *win-3-patches* + for n = (read-byte win-com nil nil) + for idx from 16 + until (null n) + when (neq idx (first (first patches))) + do (write-byte n cloe-com) + else + do (when (not (= n (second (first patches)))) + (error "Value to be patched at ~X is wrong: is ~X, expected ~X" + idx n (second (first patches)))) + (write-byte (third (first patches)) cloe-com) + (pop patches))) + (format t "done~%") + (values (namestring cloe-pn) t t)))))))) + +;;; Find the windows WIN.COM file by searching PATH +(defun find-windows-com () + (cond (*win2-com* (values *win-com* nil nil)) + (*win3-com* (values *win3-com* t nil)) + (t + (flet ((check (dir) + (declare (sys:downward-function)) + (multiple-value-bind (com win3-p cloe-p) + (find-windows-com-1 dir) + (when com + (return-from find-windows-com + (values com win3-p cloe-p)))))) + (check ".") + (map-over-path #'check) + (check "\\WINDOWS") + (error "Cannot find windows .COM file"))))) + +(defun find-winfe-exe () + (cond ((position #\\ *winfe-exe*) + (let ((path (merge-pathnames *winfe-exe*))) + (when (probe-file path) + (return-from find-winfe-exe (namestring path))))) + (t + (map-over-path + #'(lambda (dir) + (declare (sys:downward-function)) + (let ((path (merge-pathnames (concatenate 'string dir "\\" *winfe-exe*)))) + (when (probe-file path) + (return-from find-winfe-exe (namestring path)))))))) + (error "Cannot find the Winfe.exe file: ~A" *winfe-exe*)) + +;;note, this always causes 'unbalanced paren' error in zmacs, pay no mind +(defun map-over-path (continuation) + (let ((path (sys::getenv "PATH"))) + (loop for oidx = 0 then (1+ idx) + for idx = (position #\; path :start oidx) + for dir = (subseq path oidx idx) + do (funcall continuation dir) + while idx))) + +(defvar *command-string-in-use* nil) +(defvar *command-string* (make-array 260 :element-type 'string-char)) + +(defmacro with-fast-command ((command code length &key reply) &body body) + (when (null command) (setf command '.command.)) + `(multiple-value-prog1 + (let ((,command *command-string*) + (*command-string-in-use* t)) + (setf (schar ,command 0) (code-char ,code)) + (setf (schar ,command 1) (code-char ,length)) + ,@body + ,(if reply + `(send-command-await-response nil ,command) + `(send-command-string nil ,command))) + (exit-gc-cursor))) + +(defvar *gc-cursor*) +(defvar *old-cursor* nil) + +(defun enter-gc-cursor (&rest ignore) + (when (and (not *command-string-in-use*) + (not *processing-vanilla-event*) + (null *old-cursor*)) + (setq *old-cursor* (set-mouse-cursor *gc-cursor*)))) + +(defun exit-gc-cursor (&rest ignore) + (when (and (not *command-string-in-use*) + (not *processing-vanilla-event*) + *old-cursor*) + (set-mouse-cursor (shiftf *old-cursor* nil)))) + +(defun si::*gc-start-hook* (x) + (funcall si::*gc-start-hook* x)) + +(defun si::*gc-stop-hook* (x) + (funcall si::*gc-stop-hook* x)) + +(defun replace-com-string (com) + (concatenate 'string (subseq com 0 (1+ (position #\\ com :from-end t))) + *standard-stub*)) + + +(defun start-windows () + (when *windows-enabled* + (error "Windows is already started.")) + (multiple-value-bind (com win3-p) (find-windows-com) + (when *windows-standard-mode* + (setf com (replace-com-string com))) + (let ((command-string (format nil " ~:[~;/R ~]~A" win3-p + (find-winfe-exe))) + (startup-directory (si::getcwd))) + (format t "~&Starting WINDOWS ~:[2~;3~]: ~A~A~%" win3-p com command-string) + (setf (aref command-string 0) (code-char (1- (length command-string)))) + + (si::win%open com command-string) + ;;restore the startup directory, which gets munged by standard mode + (change-directory startup-directory))) + (setq *old-terminal-io* *terminal-io*) + (setq *stream* (si::make-encapsulated-primitive-stream lisp::*windows-io*)) + (setq *terminal-io* *stream* + rh::*raw-outstream* *stream* + rh::*stream* *stream*) + (setq *windows-enabled* t) + (setq *gc-cursor* (loadcursor IDC_WAIT)) + (setq si::*gc-start-hook* 'enter-gc-cursor + si::*gc-stop-hook* 'exit-gc-cursor) + t) + +(defun stop-windows () + (setq si::*gc-start-hook* nil + si::*gc-stop-hook* nil) + (setq *windows-enabled* nil) + (setq *terminal-io* *old-terminal-io* + rh::*raw-outstream* *old-terminal-io* + rh::*stream* *old-terminal-io*) + (with-fast-command (command *vm-bcom-set-state* 1) + (setf (schar command 2) (code-char *VM-STATE-STOP*))) + (loop doing (si::win%idle))) + + +(defvar *uid-string* (make-array 3 :element-type 'string-char)) + +(defun send-command-string (code string &optional (zero-term nil) (uid nil)) + ;; First, process any events that might be pending + (await-response -1 nil nil) + (when uid + (setf (schar *uid-string* 0) (code-char *VM-BCOM-UID*)) + (setf (schar *uid-string* 1) (code-char 1)) + (setf (schar *uid-string* 2) (code-char uid)) + (si::win%send *uid-string*)) + (cond ((null code) + ;; Superfast case + (si::win%send string)) + (t + ;; Need to copy + (let ((string-remaining (length string)) + (*command-string-in-use* t)) + (declare (fixnum string-remaining)) + (cond ((< string-remaining 255) + ;; Fast case + (dotimes (i string-remaining) + (declare (fixnum i)) + (setf (schar *command-string* (+ i 2)) (aref string i))) + (setf (schar *command-string* 0) (code-char code)) + (cond (zero-term + (setf (schar *command-string* 1) (code-char (1+ string-remaining))) + (setf (schar *command-string* (+ string-remaining 2)) (code-char 0))) + (t + (setf (schar *command-string* 1) (code-char string-remaining)))) + (si::win%send *command-string*)) + (t + (loop with string-idx = 0 + with idx + for first-time = t then nil + for string-remaining = (length string) then (- string-remaining 255) + for this-len = (max 0 (min 255 string-remaining)) + while (or first-time (> string-remaining 0) zero-term) + do (setq idx 2) + (dotimes (i this-len) + (setf (schar *command-string* idx) (aref string string-idx)) + (incf idx) + (incf string-idx)) + (when (and (< this-len 255) zero-term) + ;; Need zero termination and have room + (setf (schar *command-string* idx) (code-char 0)) + (setq zero-term nil) + (incf this-len)) + (setf (schar *command-string* 1) (code-char this-len)) + (setf (schar *command-string* 0) + (if (and (<= string-remaining 255) (not zero-term)) + (code-char code) + (code-char *VM-BCOM-LONG-MESSAGE*))) + (si::win%send *command-string*))))) + (exit-gc-cursor)))) + +(defconstant *bcom-max-uid* 16) +(defvar *bcom-uid-array* (make-array *bcom-max-uid*)) +(defvar *bcom-uid* 0) + +(defun await-response (uid wait-p event-p) + (loop with code and length and args and ruid and res + do (multiple-value-setq (code length args) + (receive-command-string wait-p t)) + (cond ((or (null code) (eq code T)) + ;; An event or no wait; if a response for us came back + ;; somewhere else, return it. Else, if an event and want + ;; to wake up, return, else loop. Otherwise, wait flag + ;; must be false, just return NIL. + (cond ((and (>= uid 0) + (setq res (aref *bcom-uid-array* uid))) + (return (values-list res))) + (t (return nil)))) + ((/= code *VM-BCOM-UID*) + ;; Didn't get a UID back! Hope this is the right response + ;; and just return it. + (return (values code length args))) + ((= (setq ruid (char-code (aref args 0))) uid) + ;; The next result is for us. WINFE guarantees that there + ;; will be no intervening responses between the UID and + ;; the real response. + (return (receive-command-string t nil))) + (t ;; This result is for someone else + (multiple-value-setq (code length args) + (receive-command-string t nil)) + (setf (aref *bcom-uid-array* ruid) + (list code length (copy-seq args))))))) + +(defun send-command-await-response (code string &optional (zero-term nil)) + (let ((uid (setq *bcom-uid* (mod (1+ *bcom-uid*) *bcom-max-uid*)))) + (setf (aref *bcom-uid-array* uid) nil) + (send-command-string code string zero-term uid) + (await-response uid t nil))) + +(defvar *response-string* (make-array 260 :element-type 'string-char)) +(defvar *args-portion* (make-array (- (length *response-string*) 2) + :displaced-to *response-string* + :displaced-index-offset 2 + :element-type 'string-char)) + +(defvar *processing-vanilla-event* nil) + +(defun receive-command-string (&optional (wait-p t) event-p) + (when *processing-vanilla-event* + (error "Can't send commands from the event handler.")) + (let ((events nil) + (*processing-vanilla-event* t)) + (loop + (unless (si::win%receive *response-string* wait-p) + (return events)) + (let ((code (char-code (schar *response-string* 0))) + (length (char-code (schar *response-string* 1))) + (args *args-portion*)) + (declare (fixnum code length)) + (unless (or (= code *VM-BCOM-VANILLA-EVENT*) + (= code *VM-BCOM-PAINT-EVENT*)) + (return (values code length args))) + (vanilla-event code length args) + (when event-p + (setf events t) + (setf wait-p nil)))))) + +;;make it so we don't have to load cloe-eve after reloading this. +(unless (fboundp 'vanilla-event) + (defun vanilla-event (code length args) + (declare (ignore code length args)) + nil)) + +(defmacro get-16bit (string index) + `(let ((.low. (char-code (aref ,string ,index))) + (.high. (char-code (aref ,string (+ ,index 1))))) + (declare (fixnum .high. .low.)) + (logior .low. (ash .high. 8)))) + +(defun menu-choose (caption &rest items) + (if *windows-enabled* + (menu-choose-windows caption items) + (menu-choose-dumb caption items))) + +(defun menu-choose-dumb (caption items) + (setq caption (string caption)) + (format t "~&~A~%" caption) + (if (null items) + nil + (let ((count 0)) + (dolist (item items) + (format t "~D: ~A~%" (incf count) item)) + (format t "Choice: ") + (loop for response = (read) + when (and (typep response 'fixnum) + (> response 0) + (<= response count)) + return (values (nth (- response 1) items) + (- response 1) 0) + do (format t "~&Please try again: "))))) + +(defun menu-choose-windows (caption items) + (send-command-string *VM-BCOM-START-MENU* "") + (when caption + (send-command-string *VM-BCOM-MENU-CAPTION* (string caption) t)) + (dolist (i items) + (send-command-string *VM-BCOM-MENU-ITEM* + (format nil " ~A " (string i)) t)) + (multiple-value-bind (command l cstring) + (send-command-await-response *VM-BCOM-MENU-CHOOSE* "") + (cond ((= command *VM-BCOM-MENU-SELECTION*) + (values (nth (setq l (char-code (aref cstring 0))) items) + l + (char-code (aref cstring 1)))) + (t ;(= command *VM-BCOM-CANCEL*) + nil)))) + + +(defun get-pathname (&optional (default "*.*")) + (if *windows-enabled* + (get-pathname-windows (win::get-focus) :default default) + (get-pathname-dumb default))) + +(defun get-pathname-dumb (default) + (format t "~&Enter a filename (default ~A): " default) + (merge-pathnames (parse-namestring (read-line)) + (parse-namestring default)) + ) + +(defun get-pathname-windows (window &key (default "*.*") + (caption "File Choose")) + (store-string-arg default) + (store-string-arg caption) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-GET-PATHNAME* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-GET-PATHNAME*) + (subseq cstring 0 l) + ;(get-16bit cstring 0) + nil))) + +(defmacro store-16bit (string index value) + (typecase value + ((or integer symbol) + `(progn + (setf (schar ,string ,index) (code-char (logand ,value #x0FF))) + (setf (schar ,string (+ ,index 1)) (code-char (logand (ash ,value -8) #x0FF))))) + (otherwise + `(let ((.value. ,value)) + (declare (fixnum .value.)) + (store-16bit ,string ,index .value.))))) + +;;;*** Anti-bignum kludge. Take a 28-bit fixnum, and store it so +;;;*** the C side will see it as a 32-bit fixnum with the four low +;;;*** bits 0. This is useful for create-window flags and for +;;;*** RGB values, neither of which use the low bits. +(defmacro store-28bit (string index value) + `(let ((.low. (ash (logand ,value #x0FFF) 4)) + (.high. (logand (ash ,value -12) #x0FFFF))) + (declare (fixnum .high. .low.)) + (store-16bit ,string ,index .low.) + (store-16bit ,string (+ ,index 2) .high.))) + +(defmacro store-24bit (string index value) + `(let ((.low. (logand ,value #x0FFFF)) + (.high. (logand (ash ,value -16) #x00FF))) + (declare (fixnum .high. .low.)) + (store-16bit ,string ,index .low.) + (store-16bit ,string (+ ,index 2) .high.))) + +(defun store-string-arg (string) + (send-command-string *VM-BCOM-STRING-ARG* string t)) + +(defun draw-line (x0 y0 x1 y1) + (declare (fixnum x0 y0 x1 y1)) + (with-fast-command (*line* *VM-BCOM-DRAW-LINE* 8) + (store-16bit *line* 2 x0) + (store-16bit *line* 4 y0) + (store-16bit *line* 6 x1) + (store-16bit *line* 8 y1))) + +(defun draw-char (char x y) + (declare (fixnum x y)) + (with-fast-command (*char* *VM-BCOM-DRAW-CHAR* 5) + (setf (schar *char* 2) char) + (store-16bit *char* 3 x) + (store-16bit *char* 5 y))) + +;;; Generic windows functions + +(defun get-term-window () + (multiple-value-bind (command l cstring) + (with-fast-command (nil *VM-BCOM-GET-TERM-WINDOW* 0 :reply t)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun get-dc (window) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-GET-DC* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-DC-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun release-dc (window dc) + (declare (fixnum window dc)) + (with-fast-command (*release* *VM-BCOM-RELEASE-DC* 4) + (store-16bit *release* 2 window) + (store-16bit *release* 4 dc))) + +(defun begin-paint (window) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-BEGIN-PAINT* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-DC-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun end-paint (window) + (declare (fixnum window)) + (with-fast-command (*window* *VM-BCOM-END-PAINT* 2) + (store-16bit *window* 2 window))) + +(defun create-window (cname wname style x y w h parent menu instance param) + (declare (fixnum style x y w h parent menu instance)) + (store-string-arg cname) /* ClassName */ + (store-string-arg wname) /* WindowName */ + (store-string-arg param) + (multiple-value-bind (command l cstring) + (with-fast-command (*cwindow* *VM-BCOM-CREATE-WINDOW* 18 :reply t) + (store-28bit *cwindow* 2 style) + (store-16bit *cwindow* 6 x) + (store-16bit *cwindow* 8 y) + (store-16bit *cwindow* 10 w) + (store-16bit *cwindow* 12 h) + (store-16bit *cwindow* 14 parent) + (store-16bit *cwindow* 16 menu) + (store-16bit *cwindow* 18 instance)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun move-window (window x y w h repaint) + (declare (fixnum window x y w h)) + (with-fast-command (*mwindow* *VM-BCOM-MOVE-WINDOW* 12) + (store-16bit *mwindow* 2 window) + (store-16bit *mwindow* 4 x) + (store-16bit *mwindow* 6 y) + (store-16bit *mwindow* 8 w) + (store-16bit *mwindow* 10 h) + (store-16bit *mwindow* 12 (if repaint 1 0)))) + +(defun move-to (dc x y) + (declare (fixnum dc x y)) + (with-fast-command (*dcxy* *VM-BCOM-MOVE-TO* 6) + (store-16bit *dcxy* 2 dc) + (store-16bit *dcxy* 4 x) + (store-16bit *dcxy* 6 y))) + +(defun line-to (dc x y) + (declare (fixnum dc x y)) + (with-fast-command (*dcxy* *VM-BCOM-LINE-TO* 6) + (store-16bit *dcxy* 2 dc) + (store-16bit *dcxy* 4 x) + (store-16bit *dcxy* 6 y))) + +(defun text-out (dc x y string &aux (slen (length string))) + (declare (fixnum dc x y slen)) + (store-string-arg string) + (with-fast-command (*text-out* *VM-BCOM-TEXT-OUT* 8) + (store-16bit *text-out* 2 dc) + (store-16bit *text-out* 4 x) + (store-16bit *text-out* 6 y) + (store-16bit *text-out* 8 slen))) + +(defun ellipse (dc xLeft yTop xRight yBottom) + (declare (fixnum dc xLeft yTop xRight yBottom)) + (with-fast-command (*ellipse* *VM-BCOM-ELLIPSE* 10) + (store-16bit *ellipse* 2 dc) + (store-16bit *ellipse* 4 xLeft) + (store-16bit *ellipse* 6 yTop) + (store-16bit *ellipse* 8 xRight) + (store-16bit *ellipse* 10 yBottom))) + +(defun rectangle (dc xLeft yTop xRight yBottom) + (declare (fixnum dc xLeft yTop xRight yBottom)) + (incf xRight) + (incf yBottom) + (with-fast-command (*rectangle* *VM-BCOM-RECTANGLE* 10) + (store-16bit *rectangle* 2 dc) + (store-16bit *rectangle* 4 xLeft) + (store-16bit *rectangle* 6 yTop) + (store-16bit *rectangle* 8 xRight) + (store-16bit *rectangle* 10 yBottom))) + +(defun show-window (window &key (type :show-maximized)) + (declare (fixnum window)) + (let ((command (ecase type + (:hide sw_hide) + (:minimize sw_minimize) + (:show-normal sw_shownormal) (:restore sw_restore) + (:show sw_show) + (:show-maximized sw_showmaximized) + (:show-minimized sw_showminimized) + (:show-minimized-no-activate sw_showminnoactive) + (:show-na sw_showna) + (:show-no-activate sw_shownoactivate)))) + (with-fast-command (*show-window* *VM-BCOM-SHOW-WINDOW* 4) + (store-16bit *show-window* 2 window) + (store-16bit *show-window* 4 command)))) + +(defun destroy-window (window) + (declare (fixnum window)) + (with-fast-command (*window* *VM-BCOM-DESTROY-WINDOW* 2) + (store-16bit *window* 2 window))) + +(defun set-focus (window) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-SET-FOCUS* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun get-focus () + (multiple-value-bind (command l cstring) + (with-fast-command (nil *VM-BCOM-GET-FOCUS* 0 :reply t)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun get-update-rect (window erasep) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*selobject* *VM-BCOM-GET-UPDATE-RECT* 4 :reply t) + (store-16bit *selobject* 2 window) + (store-16bit *selobject* 4 (if erasep 1 0))) + (if (= command *VM-BCOM-RECT-VALUE*) + (values (get-16bit cstring 0) ; left + (get-16bit cstring 2) ; top + (get-16bit cstring 4) ; bottom + (get-16bit cstring 6) ; right + ) + nil))) + +(defun get-client-rectangle (window) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-GET-CLIENT-RECTANGLE* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-RECT-VALUE*) + (values (get-16bit cstring 0) ; left + (get-16bit cstring 2) ; top + (get-16bit cstring 4) ; bottom + (get-16bit cstring 6) ; right + ) + nil))) + +(defun window-from-point (x y) + (declare (fixnum x y)) + (multiple-value-bind (command l cstring) + (with-fast-command (*selobject* *VM-BCOM-WINDOW-FROM-POINT* 4 :reply t) + (store-16bit *selobject* 2 x) + (store-16bit *selobject* 4 y)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun scroll-dc (dc x y l1 t1 r1 b1 l2 t2 r2 b2) + (declare (fixnum dc x y l1 t1 r1 b1 l2 t2 r2 b2)) + (with-fast-command (*scroll* *VM-BCOM-SCROLL-DC* 22) + (store-16bit *scroll* 2 dc) + (store-16bit *scroll* 4 x) + (store-16bit *scroll* 6 y) + (store-16bit *scroll* 8 l1) + (store-16bit *scroll* 10 t1) + (store-16bit *scroll* 12 r1) + (store-16bit *scroll* 14 b1) + (store-16bit *scroll* 16 l2) + (store-16bit *scroll* 18 t2) + (store-16bit *scroll* 20 r2) + (store-16bit *scroll* 22 b2))) + +(defun arc (dc x1 y1 x2 y2 x3 y3 x4 y4) + (declare (fixnum dc x1 y1 x2 y2 x3 y3 x4 y4)) + (with-fast-command (*arc* *VM-BCOM-ARC* 18) + (store-16bit *arc* 2 dc) + (store-16bit *arc* 4 x1) + (store-16bit *arc* 6 y1) + (store-16bit *arc* 8 x2) + (store-16bit *arc* 10 y2) + (store-16bit *arc* 12 x3) + (store-16bit *arc* 14 y3) + (store-16bit *arc* 16 x4) + (store-16bit *arc* 18 y4))) + +(defun pie (dc x1 y1 x2 y2 x3 y3 x4 y4) + (declare (fixnum dc x1 y1 x2 y2 x3 y3 x4 y4)) + (with-fast-command (*arc* *VM-BCOM-PIE* 18) + (store-16bit *arc* 2 dc) + (store-16bit *arc* 4 x1) + (store-16bit *arc* 6 y1) + (store-16bit *arc* 8 x2) + (store-16bit *arc* 10 y2) + (store-16bit *arc* 12 x3) + (store-16bit *arc* 14 y3) + (store-16bit *arc* 16 x4) + (store-16bit *arc* 18 y4))) + +(defvar *polygon* (make-array 1 :element-type 'string-char :fill-pointer 0)) + +(defun polygon (dc list-of-points &optional (x-offset 0) (y-offset 0)) + (declare (fixnum dc)) + (let* ((len (length list-of-points)) + (alen (+ (* 2 len) 4))) + (declare (fixnum len alen)) + (when (oddp len) (error "Polygons must have even number of points")) + (cond ((< alen 255) + (with-fast-command (command *VM-BCOM-POLYGON* alen) + (store-16bit command 2 dc) + (store-16bit command 4 (the fixnum (truncate len 2))) + (let ((list list-of-points) + (ind 6)) + (declare (fixnum ind)) + (loop + (when (null list) (return)) + (store-16bit command ind (round (+ (pop list) x-offset))) + (incf ind 2) + (store-16bit command ind (round (+ (pop list) y-offset))) + (incf ind 2))))) + (t + (when (< (array-total-size *polygon*) alen) + (setf *polygon* (make-array alen :element-type 'string-char :fill-pointer 0))) + (setf (fill-pointer *polygon*) alen) + (store-16bit *polygon* 0 dc) + (store-16bit *polygon* 2 (the fixnum (truncate len 2))) + (let ((list list-of-points) + (ind 4)) + (declare (fixnum ind)) + (loop + (when (null list) (return)) + (store-16bit *polygon* ind (round (+ (pop list) x-offset))) + (incf ind 2) + (store-16bit *polygon* ind (round (+ (pop list) y-offset))) + (incf ind 2))) + (send-command-string *VM-BCOM-POLYGON* *polygon*))))) + +(defun polyline (dc list-of-points &optional closed (x-offset 0) (y-offset 0)) + (declare (fixnum dc x-offset y-offset)) + (let* ((len (+ (length list-of-points) (if closed 2 0))) + (alen (+ (* 2 len) 4))) + (declare (fixnum len alen)) + (when (oddp len) (error "Polygons must have even number of points")) + (cond ((< alen 255) + (with-fast-command (command *VM-BCOM-POLYLINE* alen) + (store-16bit command 2 dc) + (store-16bit command 4 (the fixnum (truncate len 2))) + (let ((list list-of-points) + (ind 6)) + (declare (fixnum ind)) + (loop + (when (null list) (return)) + (store-16bit command ind (round (+ (pop list) x-offset))) + (incf ind 2) + (store-16bit command ind (round (+ (pop list) y-offset))) + (incf ind 2)) + (when closed + (store-16bit command ind (round (+ (first list-of-points) x-offset))) + (incf ind 2) + (store-16bit command ind (round (+ (second list-of-points) y-offset))) + (incf ind 2))))) + (t + (when (< (array-total-size *polygon*) alen) + (setf *polygon* (make-array alen :element-type 'string-char :fill-pointer 0))) + (setf (fill-pointer *polygon*) alen) + (store-16bit *polygon* 0 dc) + (store-16bit *polygon* 2 (the fixnum (truncate len 2))) + (let ((list list-of-points) + (ind 4)) + (declare (fixnum ind)) + (loop + (when (null list) (return)) + (store-16bit *polygon* ind (round (+ (pop list) x-offset))) + (incf ind 2) + (store-16bit *polygon* ind (round (+ (pop list) y-offset))) + (incf ind 2)) + (when closed + (store-16bit *polygon* ind (round (+ (first list-of-points) x-offset))) + (incf ind 2) + (store-16bit *polygon* ind (round (+ (second list-of-points) y-offset))) + (incf ind 2))) + (send-command-string *VM-BCOM-POLYLINE* *polygon*))))) + +(defun create-pen (style width color) + (declare (fixnum style width color)) + (multiple-value-bind (command l cstring) + (with-fast-command (*create-pen* *VM-BCOM-CREATE-PEN* 8 :reply t) + (store-16bit *create-pen* 2 style) + (store-16bit *create-pen* 4 width) + (store-24bit *create-pen* 6 color)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun create-font (height width escapement orientation weight + italic underline strikeout charset outputprecision + clipprecision quality pitchandfamily facename) + (declare (fixnum height width escapement orientation weight + italic underline strikeout charset outputprecision + clipprecision quality pitchandfamily)) + (store-string-arg facename) + (multiple-value-bind (command l cstring) + (with-fast-command (*create-font* *VM-BCOM-CREATE-FONT* 26 :reply t) + (store-16bit *create-font* 2 height) + (store-16bit *create-font* 4 width) + (store-16bit *create-font* 6 escapement) + (store-16bit *create-font* 8 orientation) + (store-16bit *create-font* 10 weight) + (store-16bit *create-font* 12 italic) + (store-16bit *create-font* 14 underline) + (store-16bit *create-font* 16 strikeout) + (store-16bit *create-font* 18 charset) + (store-16bit *create-font* 20 outputprecision) + (store-16bit *create-font* 22 clipprecision) + (store-16bit *create-font* 24 quality) + (store-16bit *create-font* 26 pitchandfamily)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun get-text-metrics (dc) + (declare (fixnum dc)) + (multiple-value-bind (command l cstring) + (with-fast-command (*dc* *VM-BCOM-GET-TEXT-METRICS* 2 :reply t) + (store-16bit *dc* 2 dc)) + (if (= command *VM-BCOM-METRIC-VALUE*) + (values (get-16bit cstring 0) ;height + (get-16bit cstring 2) ;ascent + (get-16bit cstring 4) ; descent + (get-16bit cstring 6) ; internal leading + (get-16bit cstring 8) ; external leading + (get-16bit cstring 10) ; average char width + (get-16bit cstring 12) ; max char width + (get-16bit cstring 14) ; weight + (char-code (char cstring 16)) ;italic + (char-code (char cstring 17)) ;underlined + (char-code (char cstring 18)) ;struckout + (char-code (char cstring 19)) ;first char + (char-code (char cstring 20)) ;last char + (char-code (char cstring 21)) ;default char + (char-code (char cstring 22)) ;break char + (char-code (char cstring 23)) ;pitch and family + (char-code (char cstring 24)) ;char set + (get-16bit cstring 25) ;overhang + (get-16bit cstring 27) ;digitized aspect x + (get-16bit cstring 29) ;digitized aspect y + ) + nil))) + +(defun create-solid-brush (color) + (declare (fixnum color)) + (multiple-value-bind (command l cstring) + (with-fast-command (*create-solid-brush* *VM-BCOM-CREATE-SOLID-BRUSH* 4 :reply t) + (store-24bit *create-solid-brush* 2 color)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defvar *bitmap* (make-array (+ (* 2 8) 8) :element-type 'string-char :fill-pointer 0)) + +(defun create-bitmap (bitarray) + (multiple-value-bind (command l cstring) + (let* ((len (array-total-size bitarray)) + (alen (+ (* 2 len) 8))) + (declare (fixnum len alen)) + (cond ((< alen 255) + (with-fast-command (command *VM-BCOM-CREATE-BITMAP* alen :reply t) + (store-16bit command 2 8) ;width + (store-16bit command 4 8) ;height + (store-16bit command 6 1) ; nplanes + (store-16bit command 8 1) ; nbitcount + (dotimes (i len) + (store-16bit command (+ 10 (* 2 i)) (aref bitarray i))))) + (t + (when (< (array-total-size *bitmap*) alen) + (setf *bitmap* (make-array alen :element-type 'string-char :fill-pointer 0))) + (setf (fill-pointer *bitmap*) alen) + (store-16bit *bitmap* 0 8) ;width + (store-16bit *bitmap* 2 8) ;height + (store-16bit *bitmap* 4 1) ; nplanes + (store-16bit *bitmap* 6 1) ; nbitcount + (dotimes (i len) + (store-16bit *bitmap* (+ 8 (* 2 i)) (aref bitarray i))) + (send-command-await-response *VM-BCOM-CREATE-BITMAP* *bitmap*)))) + (if (= command *vm-bcom-handle-value*) + (get-16bit cstring 0) + nil))) + +(defun create-pattern-brush (bitmap) + (declare (fixnum bitmap)) + (multiple-value-bind (command l cstring) + (with-fast-command (*create-pattern-brush* *VM-BCOM-CREATE-PATTERN-BRUSH* 2 :reply t) + (store-16bit *create-pattern-brush* 2 bitmap)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun set-brush-org (dc x y) + (declare (fixnum dc x y)) + (with-fast-command (*dcxy* *VM-BCOM-SET-BRUSH-ORG* 6) + (store-16bit *dcxy* 2 dc) + (store-16bit *dcxy* 4 x) + (store-16bit *dcxy* 6 y))) + +(defun get-stock-object (n) + (declare (fixnum n)) + (multiple-value-bind (command l cstring) + (with-fast-command (*object* *VM-BCOM-GET-STOCK-OBJECT* 2 :reply t) + (store-16bit *object* 2 n)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun delete-object (object) + (declare (fixnum object)) + (with-fast-command (*object* *VM-BCOM-DELETE-OBJECT* 2) + (store-16bit *object* 2 object))) + +(defun get-rop2 (dc) + (declare (fixnum dc)) + (multiple-value-bind (command l cstring) + (with-fast-command (*object* *VM-BCOM-GET-ROP2* 2 :reply t) + (store-16bit *object* 2 dc)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun set-rop2 (dc rop) + (declare (fixnum dc rop)) + (with-fast-command (*setrop2* *VM-BCOM-SET-ROP2* 4) + (store-16bit *setrop2* 2 dc) + (store-16bit *setrop2* 4 rop))) + +(defun set-text-color (dc color) + (declare (fixnum dc color)) + (with-fast-command (*set-text-color* *VM-BCOM-SET-TEXT-COLOR* 6) + (store-16bit *set-text-color* 2 dc) + (store-24bit *set-text-color* 4 color))) + +(defun message-beep () + (with-fast-command (nil *VM-BCOM-BEEP* 0))) + +(defun set-scroll-position (window bar position &optional (draw-p t)) + (declare (fixnum window position)) + (with-fast-command (*set-scroll-position* *VM-BCOM-SET-SCROLL-POSITION* 8) + (store-16bit *set-scroll-position* 2 window) + (store-16bit *set-scroll-position* 4 bar) + (store-16bit *set-scroll-position* 6 position) + (store-16bit *set-scroll-position* 8 (if draw-p 1 0)))) + +(defun set-background-color (dc color) + (declare (fixnum dc color)) + (with-fast-command (*set-background-color* *VM-BCOM-SET-BACKGROUND-COLOR* 6) + (store-16bit *set-background-color* 2 dc) + (store-24bit *set-background-color* 4 color))) + +(defun set-erase-brush (dc color) + (declare (fixnum dc color)) + (with-fast-command (*set-background-color* *VM-BCOM-SET-ERASE-BRUSH* 6) + (store-16bit *set-background-color* 2 dc) + (store-24bit *set-background-color* 4 color))) + +(defun select-object (dc n) + (declare (fixnum dc n)) + (multiple-value-bind (command l cstring) + (with-fast-command (*selobject* *VM-BCOM-SELECT-OBJECT* 4 :reply t) + (store-16bit *selobject* 2 dc) + (store-16bit *selobject* 4 n)) + (if (= command *VM-BCOM-HANDLE-VALUE*) + (get-16bit cstring 0) + nil))) + +(defun select-brush (dc n) + (declare (fixnum dc n)) + (with-fast-command (*selobject* *VM-BCOM-SELECT-BRUSH* 4) + (store-16bit *selobject* 2 dc) + (store-16bit *selobject* 4 n))) + +(defun select-pen (dc n) + (declare (fixnum dc n)) + (with-fast-command (*selobject* *VM-BCOM-SELECT-PEN* 4) + (store-16bit *selobject* 2 dc) + (store-16bit *selobject* 4 n))) + +(defun select-bitmap (dc n) + (declare (fixnum dc n)) + (with-fast-command (*selobject* *VM-BCOM-SELECT-BITMAP* 4) + (store-16bit *selobject* 2 dc) + (store-16bit *selobject* 4 n))) + +(defun select-font (dc n) + (declare (fixnum dc n)) + (with-fast-command (*selobject* *VM-BCOM-SELECT-FONT* 4) + (store-16bit *selobject* 2 dc) + (store-16bit *selobject* 4 n))) + +(defun select-region (dc n) + (declare (fixnum dc n)) + (with-fast-command (*selobject* *VM-BCOM-SELECT-REGION* 4) + (store-16bit *selobject* 2 dc) + (store-16bit *selobject* 4 n))) + +(defun get-text-extent (dc string) + (declare (fixnum dc)) + (store-string-arg string) + (multiple-value-bind (command l cstring) + (with-fast-command (*get-text-extent* *VM-BCOM-GET-TEXT-EXTENT* 4 :reply t) + (store-16bit *get-text-extent* 2 dc) + (store-16bit *get-text-extent* 4 (length string))) + (if (= command *VM-BCOM-RECT-VALUE*) + (values (get-16bit cstring 4) ;right + (get-16bit cstring 6) ;bottom + ) + nil))) + +(defmacro with-dc ((dc-variable window) &body body) + `(let ((,dc-variable ,window)) + ,@body)) + +#+old-code +(defmacro with-dc ((dc-variable window) &body body) + `(let ((,dc-variable (get-dc ,window))) + (unwind-protect + (progn + ,@body) + (release-dc ,window ,dc-variable)))) + +#+old-code +(defmacro with-term-dc ((dc-variable) &body body) + `(let ((,dc-variable (get-dc (get-term-window)))) + (unwind-protect + (progn + ,@body) + (release-dc (get-term-window) ,dc-variable)))) + +(defun get-screen-size () + (multiple-value-bind (command l cstring) + (with-fast-command (nil *VM-BCOM-GET-SCREEN-SIZE* 0 :reply t)) + (values (get-16bit cstring 0) + (get-16bit cstring 2)))) + +(defun get-pointer-position () + (multiple-value-bind (command l cstring) + (with-fast-command (nil *VM-BCOM-GET-POINTER-POSITION* 0 :reply t)) + (values (get-16bit cstring 0) + (get-16bit cstring 2)))) + +(defun set-pointer-position (screen-x screen-y) + (declare (fixnum screen-x screen-y)) + (with-fast-command (*xyposition* *VM-BCOM-SET-POINTER-POS* 4) + (store-16bit *xyposition* 2 screen-x) + (store-16bit *xyposition* 4 screen-y))) + +;;; Mouse cursor stuff + +;;; Calls LoadCursor with id as 16 bit arg and returns the handle +(defun loadcursor (id) + (multiple-value-bind (command l cstring) + (with-fast-command (*cursobject* *VM-BCOM-LOADCURSOR* 2 :reply t) + (store-16bit *cursobject* 2 id)) + (get-16bit cstring 0))) + +;;; Sets the mouse cursor for all WINFE windows, and returns the either +;;; the current cursor, if WINFE has the focus, or the current value of +;;; WINFE's cursor as last set. +(defun set-mouse-cursor (hcursor) + (multiple-value-bind (command l cstring) + (with-fast-command (*cursobject* *VM-BCOM-SET-MOUSE-CURSOR* 2 :reply t) + (store-16bit *cursobject* 2 hcursor)) + (get-16bit cstring 0))) + +;;;for moving the window position and stacking order + +(defun set-window-position (window after-window x y w h flags) + (declare (fixnum window after-window x y w flags)) + (with-fast-command (*swindowp* *VM-BCOM-SET-WINDOW-POS* 14) + (store-16bit *swindowp* 2 window) + (store-16bit *swindowp* 4 after-window) + (store-16bit *swindowp* 6 x) + (store-16bit *swindowp* 8 y) + (store-16bit *swindowp* 10 w) + (store-16bit *swindowp* 12 h) + (store-16bit *swindowp* 14 flags))) + +;;sets the windows title pane +(defun set-window-text (window text) + (declare (fixnum window)) + (store-string-arg text) + (with-fast-command (*window* *VM-BCOM-SET-WINDOW-TEXT* 2) + (store-16bit *window* 2 window))) + +(defun get-window-rectangle (window) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-GET-WINDOW-RECTANGLE* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-RECT-VALUE*) + (values (get-16bit cstring 0) ; left + (get-16bit cstring 2) ; top + (get-16bit cstring 4) ; bottom + (get-16bit cstring 6) ; right + ) + nil))) + +(defun show-scroll-bar (window wbar show-p) + (declare (fixnum window)) + (with-fast-command (*scroll-bar* *VM-BCOM-SHOW-SCROLL-BAR* 6) + (store-16bit *scroll-bar* 2 window) + (store-16bit *scroll-bar* 4 wbar) + (store-16bit *scroll-bar* 6 (if show-p 1 0)))) + +(defun is-iconic (window) + (declare (fixnum window)) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-IS-ICONIC* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (not (zerop (get-16bit cstring 0))) + ;;probably not important, but avoid confusion vs returning nil + (progn + (cerror "Return T anyway" "Is-iconic didn't return") + (values t))))) + + +(defun notify-user (window message) + (declare (fixnum window)(string message)) + (store-string-arg message) + (with-fast-command (*window* *VM-BCOM-NOTIFY-USER* 2) + (store-16bit *window* 2 window))) + +(defun run-windows-application (application &optional (show SW_NORMAL)) + (declare (string application)(fixnum show)) + (store-string-arg application) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-WINDOW-EXEC* 2 :reply t) + (store-16bit *window* 2 show)) + (if (= command *VM-BCOM-WINDOW-VALUE*) + (let ((return-value (get-16bit cstring 0))) + (declare (fixnum return-value)) + ;;a value less than 32 means it couldn't do it + (unless (> return-value 32) + (error "Unable to start ~A, error code returned was ~D" + application return-value)))) + t)) + +;;this should probably be in the low-level CLOE sources, with +;;getcwd, but it was easier and quicker here. +(defun change-directory (path) + (declare (string path)) + (store-string-arg path) + (multiple-value-bind (command l cstring) + (with-fast-command (nil *VM-BCOM-CHANGE-DIR* 0)))) + + +;;these functions set up the blinking cursor, it needs to be +;;cleaned up more before making it the default + +(defun show-caret (window) + (declare (fixnum window)) + (with-fast-command (*window* *VM-BCOM-SHOW-CARET* 2))) + +(defun hide-caret () + (with-fast-command (nil *VM-BCOM-HIDE-CARET* 0))) + + +(defun set-caret-pos (x y) + (declare (fixnum x y)) + (with-fast-command (*coordinates* *VM-BCOM-SET-CARET-POS* 4) + (store-16bit *coordinates* 2 x) + (store-16bit *coordinates* 4 y))) + +;;; + +(defun select-file-dialog-box (window &key (default "*.*") + (caption "File Choose")) + (store-string-arg default) + (store-string-arg caption) + (multiple-value-bind (command l cstring) + (with-fast-command (*window* *VM-BCOM-GET-PATHNAME* 2 :reply t) + (store-16bit *window* 2 window)) + (if (= command *VM-BCOM-GET-PATHNAME*); cancel returned if no selection + (subseq cstring 0 l) + nil))) + + +;;helps to redraw scrollbar buttons when they don't appear, but +;;calling this only works some times +(defun paint-nonclient-area (window) + (declare (fixnum window)) + (with-fast-command (*window* *VM-BCOM-NONCLIENT-PAINT* 2) + (store-16bit *window* 2 window))) + + +(defvar *editor-for-windows* "epsilon") + +(in-package 'user) ;;;NOTE!!!!! + +;;starts up dos, then you can switch back and forth using ^tab +;;if you give it a string, it will do that command and then exit +(defun command (&optional string) + (win::run-windows-application + (if string + (concatenate 'string "command.com /c " string) + "command.com"))) + +;;poor mans editor +(defun notepad (&optional file) + (win::run-windows-application (concatenate 'string + "notepad " + file))) + + + +;;Frob the ed function to work for both windows and cloe +(defvar non-windows-ed nil) +(setf (symbol-function 'non-windows-ed) (symbol-function 'ed)) + +;;real editor, exit brings you back to windows +;;This needs to actually be merged with ED that works when +;;windows is not enabled... +(defun ed (&optional file) + (if (not win::*windows-enabled*) + (non-windows-ed file) + (win::run-windows-application (concatenate 'string + "command.com /c " + *editor-for-windows* + " " + file)))) + +(in-package 'win) ;; so when more code gets added + + + + diff --git a/utils/ccl-streams.lisp b/utils/ccl-streams.lisp new file mode 100644 index 00000000..cc6d8e37 --- /dev/null +++ b/utils/ccl-streams.lisp @@ -0,0 +1,16 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;; If we were really being clever, we could put CCL methods for +;; STREAM-CLOSE and STREAM-ABORT onto FUNDAMENTAL-STREAM here. That +;; would require having someplace to write down that the stream had +;; been aborted so when it got closed we could do something clever with +;; that information, though, so we won't do it for now... +(defgeneric close (stream &key abort)) + +(defmethod close ((stream t) &key abort) + (common-lisp:close stream :abort abort)) + diff --git a/utils/cl-stream-classes.lisp b/utils/cl-stream-classes.lisp new file mode 100644 index 00000000..8408f8a4 --- /dev/null +++ b/utils/cl-stream-classes.lisp @@ -0,0 +1,77 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +;;; All of this is taken from the STREAM-DEFINITION-BY-USER proposal to +;;; the X3J13 committee, made by David Gray of TI on 22 March 1989. No +;;; Lisp implementation yet supports this proposal, so we implement it +;;; here in this separate package. This way we will be ready when some +;;; Lisp implementation adopts it (or something like it). + +;;; This file defines classes in the Gray proposal, plus class-based +;;; predicates. This file is entirely #-CLIM-uses-Lisp-stream-classes, +;;; which means that any class and function names are shadowed in this +;;; package (not inherited from the CL package). + +(defmacro define-class-and-predicate (class-name predicate-name &body superclasses) + `(clim-utils:define-group ,class-name define-class-and-predicate + (defclass ,class-name ,@superclasses ()) + ;;--- Genera can't put both a class and methods on that class in the same group. + ,@(when predicate-name + `((define-stream-predicate-trampoline ,predicate-name ,class-name))))) + +(defmacro define-stream-predicate-trampoline (predicate-name class-name + &key lucid-kludge) + #-Lucid (declare (ignore lucid-kludge)) + (let ((lisp-predicate (or #+Lucid lucid-kludge + (find-symbol + (symbol-name predicate-name) + ;; #+Genera *Sigh*. OPEN-STREAM-P is in + ;; FUTURE-COMMON-LISP only. Of course, it's + ;; not defined yet, but at least it's exported. + #+Genera "FUTURE-COMMON-LISP" + #-Genera "COMMON-LISP")))) + (when (null lisp-predicate) + (error "No symbol ~S found in the Common-Lisp package." predicate-name)) + `(clim-utils:define-group ,predicate-name define-stream-predicate-trampoline + (defgeneric ,predicate-name (object)) + (defmethod ,predicate-name ((object t)) (,lisp-predicate object)) + ,@(when class-name + `((defmethod ,predicate-name ((object ,class-name)) 't)))))) + + +;;; The classes themselves. + +(define-class-and-predicate fundamental-stream streamp + (#+CCL-2 ccl::stream)) + +(define-class-and-predicate fundamental-input-stream input-stream-p + (fundamental-stream #+CCL-2 ccl:input-stream)) + +(define-class-and-predicate fundamental-output-stream output-stream-p + (fundamental-stream #+CCL-2 ccl:output-stream)) + +(define-class-and-predicate fundamental-character-stream nil + (fundamental-stream)) + +(define-class-and-predicate fundamental-binary-stream nil + (fundamental-stream)) + +(define-class-and-predicate fundamental-character-input-stream nil + (fundamental-input-stream fundamental-character-stream)) + +(define-class-and-predicate fundamental-character-output-stream nil + (fundamental-output-stream fundamental-character-stream)) + +(define-class-and-predicate fundamental-binary-input-stream nil + (fundamental-input-stream fundamental-binary-stream)) + +(define-class-and-predicate fundamental-binary-output-stream nil + (fundamental-output-stream fundamental-binary-stream)) + +(define-stream-predicate-trampoline open-stream-p nil + ;;--- For now. PW will dig up the right predicate + :lucid-kludge (lambda (stream) (streamp stream))) diff --git a/utils/cl-stream-functions.lisp b/utils/cl-stream-functions.lisp new file mode 100644 index 00000000..d1363ea3 --- /dev/null +++ b/utils/cl-stream-functions.lisp @@ -0,0 +1,197 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1989, 1990 International Lisp Associates." + +;;; All of this is taken from the STREAM-DEFINITION-BY-USER proposal to +;;; the X3J13 committee, made by David Gray of TI on 22 March 1989. No +;;; Lisp implementation yet supports this proposal, so we implement it +;;; here in this separate package. This way we will be ready when some +;;; Lisp implementation adopts it (or something like it). + +;;; This file defines functions in the Gray proposal. This file is +;;; entirely #-CLIM-uses-Lisp-stream-functions, which means that any +;;; class and function names are shadowed in this package (not +;;; inherited from the CL package). + + +;;; Output functions + +(defmacro write-forwarding-cl-output-stream-function (name args) + (let* ((cl-name (find-symbol (symbol-name name) (find-package 'lisp))) + (method-name (intern (lisp:format nil "STREAM-~A" (symbol-name name)))) + (optional-args (or (member '&optional args) (member '&key args))) + (required-args (ldiff args optional-args)) + (optional-parameters (mapcan #'(lambda (arg) + (cond ((member arg lambda-list-keywords) nil) + ((atom arg) (list arg)) + (t (list (car arg))))) + optional-args)) + (pass-args (append required-args optional-parameters)) + ;; optional-args are &optional in the method, + ;; even if &key in the Common Lisp function + (method-args (if (eq (first optional-args) '&key) + (append required-args '(&optional) (cdr optional-args)) + args)) + (pass-keys (if (eq (first optional-args) '&key) + (mapcan #'(lambda (arg) + (unless (atom arg) + (setq arg (car arg))) + (list (intern (string arg) "KEYWORD") arg)) + (cdr optional-args)) + optional-parameters))) + (when (eq (first optional-args) '&optional) + (pop optional-args)) + `(clim-utils:define-group ,name write-forwarding-cl-output-stream-function + (eval-when (compile load eval) (proclaim '(inline ,name))) + (defun ,name (,@required-args &optional stream ,@optional-args) + (cond ((null stream) (setq stream *standard-output*)) + ((eql stream t) (setq stream *terminal-io*))) + (,method-name stream ,@pass-args)) + + ;; Define a default method for the generic function that calls back to the + ;; system stream implementation. Call back via a message if there is one, + ;; otherwise via the Common Lisp function. + ;; Uses T as a parameter specializer name as a standin for cl:stream, + ;; which Genera doesn't support as a builtin class + (defmethod ,method-name ((stream t) ,@method-args) + (,cl-name ,@required-args stream ,@pass-keys))))) + +(write-forwarding-cl-output-stream-function write-byte (integer)) + +(write-forwarding-cl-output-stream-function write-char (character)) + +(write-forwarding-cl-output-stream-function write-string (string &key (start 0) end)) + +(write-forwarding-cl-output-stream-function terpri ()) + +(write-forwarding-cl-output-stream-function fresh-line ()) + +(write-forwarding-cl-output-stream-function force-output ()) + +(write-forwarding-cl-output-stream-function finish-output ()) + +(write-forwarding-cl-output-stream-function clear-output ()) + + +;;; Input functions + +(defmacro write-forwarding-cl-input-stream-function (name lambda-list + &key eof + additional-arguments) + (let* ((cl-name (find-symbol (symbol-name name) (find-package 'lisp))) + (method-name (intern (lisp:format nil "STREAM-~A" (symbol-name name)))) + (method-lambda-list (remove 'stream lambda-list)) + (args (mapcar #'(lambda (var) (if (atom var) var (first var))) + (remove-if #'(lambda (x) (member x lambda-list-keywords)) + lambda-list))) + (stream-args (remove 'stream args)) + (cleanup `(cond ((null stream) (setq stream *standard-input*)) + ((eql stream t) (setq stream *terminal-io*)))) + (call-method `(,method-name stream ,@stream-args))) + (when (member (first (last method-lambda-list)) lambda-list-keywords) + (setf method-lambda-list (butlast method-lambda-list))) + `(clim-utils:define-group ,name write-forwarding-cl-input-stream-function + (eval-when (compile load eval) (proclaim '(inline ,name))) + ,(if eof + (let ((args `(eof-error-p eof-value ,@(and (not (eq eof :no-recursive)) + '(recursive-p))))) + `(defun ,name (,@lambda-list ,@args) + ,cleanup + (let ((result ,call-method)) + (cond ((not (eq result :eof)) + result) + (eof-error-p + (signal-stream-eof stream ,@(and (not (eq eof :no-recursive)) + '(recursive-p)))) + (t + eof-value))))) + `(defun ,name ,lambda-list + ,cleanup + ,call-method)) + + ;; Define a default method for the generic function that calls back to the + ;; system stream implementation. Call back via a message if there is one, + ;; otherwise via the Common Lisp function. + (defmethod ,method-name ((stream t) ,@method-lambda-list) + (,cl-name ,@additional-arguments ,@args ,@(and eof `(nil :eof))))))) + +(write-forwarding-cl-input-stream-function read-byte (&optional stream) :eof :no-recursive) + +(write-forwarding-cl-input-stream-function read-char (&optional stream) :eof t) + +(write-forwarding-cl-input-stream-function unread-char (character &optional stream)) + +(write-forwarding-cl-input-stream-function read-char-no-hang (&optional stream) :eof t) + +;;(write-forwarding-cl-input-stream-function peek-char (&optional stream) +;; :eof t :additional-arguments (nil)) + +;;; Rewritten for true Gray stream proposal. +;;; STREAM-PEEK-CHAR doesn't get a peek-type; that's all handled at the PEEK-CHAR level. +(defun peek-char (&optional peek-type input-stream (eof-error-p t) + eof-value recursive-p) + (declare (ignore recursive-p)) + (case input-stream + ((nil) (setf input-stream *standard-input*)) + ((t) (setf input-stream *standard-output*))) + (assert (or (null peek-type) (eq peek-type t) (characterp peek-type)) + (peek-type) + "Illegal peek type ~S" peek-type) + (loop + (let ((ch (stream-peek-char input-stream))) + (cond ((eq ch :eof) + (if eof-error-p + (signal-stream-eof input-stream recursive-p) + (return-from peek-char eof-value))) + ((or (null peek-type) + (and (eq peek-type t) + ;; --- Sorry, bad modularity. Fixed in 2.0 packages + (not (clim-internals::whitespace-char-p ch))) + (eq peek-type ch)) + (return-from peek-char ch)))))) + +(write-forwarding-cl-input-stream-function listen (&optional stream)) + +(write-forwarding-cl-input-stream-function read-line (&optional stream) :eof t) + +(write-forwarding-cl-input-stream-function clear-input (&optional stream)) + +(defun signal-stream-eof (stream &optional recursive-p) + (declare (ignore recursive-p)) + (error 'end-of-file :stream stream)) + + +;;; PATHNAME and TRUENAME + +(defgeneric pathname (stream)) + +(defmethod pathname (stream) + (lisp:pathname stream)) + +(deftype pathname () 'lisp:pathname) + + +(defgeneric truename (stream)) + +(defmethod truename (stream) + (lisp:truename stream)) + + +;;; Make CLIM-LISP:FORMAT do something useful on CLIM windows. + +(defun format (stream format-control &rest format-args) + (when (null stream) + (return-from format + (apply #'lisp:format nil format-control format-args))) + (when (eq stream 't) + (setq stream *standard-output*)) + (cond ((streamp stream) + ;; this isn't going to quite work for ~&, + ;; but it's better than nothing. + (write-string (apply #'lisp:format nil format-control format-args) stream) + nil) + (t + (apply #'lisp:format stream format-control format-args)))) diff --git a/utils/clim-macros.lisp b/utils/clim-macros.lisp new file mode 100644 index 00000000..df089b63 --- /dev/null +++ b/utils/clim-macros.lisp @@ -0,0 +1,123 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: clim-defs.lisp,v 1.4 91/03/26 12:47:12 cer Exp $ + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." + +;;--- These need to be moved into CLIM-UTILS somewhere... +(defmacro default-output-stream (stream &optional must-be-variable-macro-name) + `(cond ((member ,stream '(t nil)) + (setq ,stream '*standard-output*)) + ,@(when must-be-variable-macro-name + `(((not (and (symbolp ,stream) + (not (keywordp ,stream)))) + (warn "The stream argument to ~S, ~S, is invalid.~@ + This argument must be a variable that can be bound to a new stream." + ',must-be-variable-macro-name ,stream) + (setq ,stream '*standard-output*)))))) + +(defmacro default-input-stream (stream &optional must-be-variable-macro-name) + `(cond ((member ,stream '(t nil)) + (setq ,stream '*standard-input*)) + ,@(when must-be-variable-macro-name + `(((not (and (symbolp ,stream) + (not (keywordp ,stream)))) + (warn "The stream argument to ~S, ~S, is invalid.~@ + This argument must be a variable that can be bound to a new stream." + ',must-be-variable-macro-name ,stream) + (setq ,stream '*standard-input*)))))) + +(defmacro default-query-stream (stream &optional must-be-variable-macro-name) + `(cond ((member ,stream '(t nil)) + (setq ,stream '*query-io*)) + ,@(when must-be-variable-macro-name + `(((not (and (symbolp ,stream) + (not (keywordp ,stream)))) + (warn "The stream argument to ~S, ~S, is invalid.~@ + This argument must be a variable that can be bound to a new stream." + ',must-be-variable-macro-name ,stream) + (setq ,stream '*query-io*)))))) + + +;;; Drawing state macros + +(defmacro with-clipping-region ((stream region) &body body) + (default-output-stream stream with-clipping-region) + `(flet ((with-clipping-region-body (,stream) ,@body)) + (declare (dynamic-extent #'with-clipping-region-body)) + (invoke-with-clipping-region ,stream #'with-clipping-region-body ,region))) + +(defmacro with-drawing-options ((medium &rest options) &body body) + (declare (arglist (medium + &key ink clipping-region transformation + line-style line-unit line-thickness line-dashes + line-joint-shape line-cap-shape + text-style text-family text-face text-size))) + #+Genera (declare (zwei:indentation 0 3 1 1)) + (default-output-stream medium) + `(flet ((with-drawing-options-body () ,@body)) + (declare (dynamic-extent #'with-drawing-options-body)) + (invoke-with-drawing-options ,medium #'with-drawing-options-body ,@options))) + +(defmacro with-identity-transformation ((medium) &body body) + `(letf-globally (((medium-transformation ,medium) +identity-transformation+)) + ,@body)) + +(defmacro with-translation ((medium dx dy) &body body) + `(with-drawing-options (,medium + :transformation (make-translation-transformation ,dx ,dy)) + ,@body)) + +(defmacro with-scaling ((medium sx &optional (sy nil sy-p)) &body body) + `(with-drawing-options (,medium + :transformation (let* ((scale-x ,sx) + (scale-y ,(if sy-p sy 'scale-x))) + (make-scaling-transformation scale-x scale-y))) + ,@body)) + +(defmacro with-rotation ((medium angle &optional (origin nil origin-p)) &body body) + `(with-drawing-options (,medium + :transformation (make-rotation-transformation ,angle + ,@(if origin-p `(,origin) nil))) + ,@body)) + +;; Establish a local +Y-downward coordinate system at the current cursor position, +;; and execute the body +(defmacro with-local-coordinates ((&optional stream x y) &body body) + (default-output-stream stream with-local-coordinates) + (let ((cx '#:cx) (cy '#:cy) + (tx '#:tx) (ty '#:ty)) + `(let ((,cx ,x) + (,cy ,y)) + (unless (and ,cx ,cy) + (multiple-value-setq (,cx ,cy) (stream-cursor-position* ,stream))) + (multiple-value-bind (,tx ,ty) + (transform-point* (medium-transformation ,stream) 0 0) + (with-drawing-options + (,stream :transformation (make-translation-transformation + (- ,cx ,tx) (- ,cy ,ty))) + ,@body))))) + +;; Establish a local +Y-upward coordinate system at the current cursor position, +;; and execute the body +(defmacro with-first-quadrant-coordinates ((&optional stream x y) &body body) + (default-output-stream stream with-first-quadrant-coordinates) + (let ((cx '#:cx) (cy '#:cy) + (tx '#:tx) (ty '#:ty)) + `(let ((,cx ,x) + (,cy ,y)) + (unless (and ,cx ,cy) + (multiple-value-setq (,cx ,cy) (stream-cursor-position* ,stream))) + (multiple-value-bind (,tx ,ty) + (transform-point* (medium-transformation ,stream) 0 0) + (with-drawing-options + ;; Don't flip the stream over if we already have + (,stream :transformation (if (silica::medium-+Y-upward-p ,stream) + +identity-transformation+ + (make-transformation 1 0 0 -1 + (- ,cx ,tx) (- ,cy ,ty)))) + (letf-globally (((silica::medium-+Y-upward-p ,stream) t)) + ,@body)))))) diff --git a/utils/clim-streams.lisp b/utils/clim-streams.lisp new file mode 100644 index 00000000..83b2df26 --- /dev/null +++ b/utils/clim-streams.lisp @@ -0,0 +1,24 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: clim-defs.lisp,v 1.4 91/03/26 12:47:12 cer Exp $ + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." + +;; STANDARD-ENCAPSULATING-STREAM needs to be defined early on, because many methods are +;; written on this class. + +(define-protocol-class encapsulating-stream (fundamental-stream)) + +;; These aren't really "encapsulating" streams, they're "delegating streams." +;; What about the delegation ("multiple self", "xstream") problem? +;; See *ORIGINAL-STREAM* for some more information. +(defclass standard-encapsulating-stream + (encapsulating-stream) + ((stream :initarg :stream + :reader encapsulating-stream-stream)) + #+Allegro (:default-initargs :element-type 'extended-char)) + + diff --git a/utils/coral-char-bits.lisp b/utils/coral-char-bits.lisp new file mode 100644 index 00000000..5872eaf1 --- /dev/null +++ b/utils/coral-char-bits.lisp @@ -0,0 +1,44 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1991 International Lisp Associates. All rights reserved." + +;; What a pain. Symbolics wrote the code to deal with CHAR-BITS, but +;; there ain't no such thing in ANSI CL. Here in Coral, at least, we +;; can temporarily kludge around it. +(defun %set-char-bits (ch b) + (declare (fixnum ch)) ; a lie + (let ((mask (ash b (- 8 3)))) ; fixnums are "shifted left" three bits + (declare (fixnum mask)) + ; I'm so ashamed + (logior ch mask))) + +(defun char-bits (ch) + (declare (fixnum ch)) + ;; Extremely gross + (ccl::lsh (logand ch (ash #x0000FF00 -3)) -5)) + +;; CHAR= has been shadowed in PKGDCL +(declaim (inline char=)) + +(defun char= (ch1 ch2) + (declare (fixnum ch1 ch2)) + ;; Really gross! + (ccl::require-type ch1 'character) + (ccl::require-type ch2'character) + (= ch1 ch2)) + +(defmacro shadow-char-p-function (name) + (let ((lisp-name (intern (symbol-name name) 'lisp))) + `(defun ,name (char) + (let ((bits (char-bits char))) + (cond ((zerop bits) + (,lisp-name char)) + (t nil)))))) + +(shadow-char-p-function graphic-char-p) +(shadow-char-p-function standard-char-p) +(shadow-char-p-function alpha-char-p) + +;; --- do we need to shadow ALPHANUMERICP ? diff --git a/utils/genera-streams.lisp b/utils/genera-streams.lisp new file mode 100644 index 00000000..77d91396 --- /dev/null +++ b/utils/genera-streams.lisp @@ -0,0 +1,116 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +;; Genera doesn't define STREAM-ELEMENT-TYPE as a generic function, so +;; we need to shadow it here. +(defgeneric stream-element-type (stream) + (:selector :stream-element-type)) + +(defmethod stream-element-type ((stream si:stream)) + (common-lisp:stream-element-type stream)) + +;; Ditto, CLOSE +(defgeneric close (stream &key abort)) + +(defmethod close ((stream t) &key abort) + (common-lisp:close stream :abort abort)) + + +(defgeneric pathname (stream)) + +(defmethod pathname (stream) + (lisp:pathname stream)) + +(deftype pathname () 'lisp:pathname) + + +(defgeneric truename (stream)) + +(defmethod truename (stream) + (lisp:truename stream)) + + +;;; Define the "reverse trampolines" for Genera, that is, stream methods on +;;; non-CLIM streams that trampoline back into Genera stream operations. + +(defgeneric stream-read-byte (stream)) +(defmethod stream-read-byte ((stream t)) + (or (scl:send stream :tyi nil) + :eof)) + +(defgeneric stream-read-char (stream)) +(defmethod stream-read-char ((stream t)) + (or (scl:send stream :tyi nil) + :eof)) + +(defgeneric stream-unread-char (stream character) + (:selector :untyi)) +(defmethod stream-unread-char ((stream t) character) + (scl:send stream :untyi character)) + +(defgeneric stream-read-char-no-hang (stream)) +(defmethod stream-read-char-no-hang ((stream t)) + (or (scl:send stream :tyi-no-hang nil) + :eof)) + +(defgeneric stream-peek-char (stream)) +(defmethod stream-peek-char ((stream t)) + (or (scl:send stream :tyipeek nil) + :eof)) + +(defgeneric stream-listen (stream) + (:selector :listen)) +(defmethod stream-listen ((stream t)) + (scl:send stream :listen)) + +(defgeneric stream-read-line (stream) + (:selector :line-in)) +(defmethod stream-read-line ((stream t)) + (read-line stream nil :eof)) ;; Doesn't map well into :LINE-IN. + +(defgeneric stream-clear-input (stream) + (:selector :clear-input)) +(defmethod stream-clear-input ((stream t)) + (scl:send stream :clear-input)) + + +(defgeneric stream-write-byte (stream char)) +(defmethod stream-write-byte ((stream t) integer) + (scl:send stream :tyo integer)) + +(defgeneric stream-write-char (stream char) + (:selector :tyo)) +(defmethod stream-write-char ((stream t) character) + (scl:send stream :tyo character)) + +(defgeneric stream-write-string (stream string &optional start end) + (:selector :string-out)) +(defmethod stream-write-string ((stream t) string &optional (start 0) end) + (scl:send stream :string-out string start end)) + +(defgeneric stream-terpri (stream)) +(defmethod stream-terpri ((stream t)) + (scl:send stream :tyo #\Newline)) + +(defgeneric stream-fresh-line (stream) + (:selector :fresh-line)) +(defmethod stream-fresh-line ((stream t)) + (scl:send stream :fresh-line)) + +(defgeneric stream-force-output (stream) + (:selector :force-output)) +(defmethod stream-force-output ((stream t)) + (scl:send stream :force-output)) + +(defgeneric stream-finish-output (stream) + (:selector :finish)) +(defmethod stream-finish-output ((stream t)) + (scl:send stream :finish)) + +(defgeneric stream-clear-output (stream) + (:selector :clear-output)) +(defmethod stream-clear-output ((stream t)) + (scl:send stream :clear-output)) diff --git a/utils/lisp-package-fixups.lisp b/utils/lisp-package-fixups.lisp new file mode 100644 index 00000000..e599d936 --- /dev/null +++ b/utils/lisp-package-fixups.lisp @@ -0,0 +1,69 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10 -*- + +#+ANSI-90 (in-package :cl-user) + +#-ANSI-90 (in-package :user) + +"Copyright (c) 1991 by International Lisp Associates. All Rights Reserved." + +;;; The point of this file is to give CLIM a consistent naming scheme +;;; for the LISP and USER packages, no matter what they are actually +;;; called in any given Lisp environment. + +;;; These two forms should be merged into one facility that does the +;;; right thing, but I am trying to make the minimal change since it +;;; is shortly before the MCL CLIM release. The two forms were both +;;; loaded as part of building CLIM before I moved them into this +;;; file, so they ought to work as well together in this file as they +;;; did separately in defsystem and sysdcl. +;;; +;;; I only moved them at all so that the magic they do to packages did +;;; not rely on having the "extra-CLIM" files DEFSYSTEM and SYSDCL +;;; loaded in order to load or run CLIM. That is, I moved the forms +;;; from files that are loaded only to compile/build CLIM into a file +;;; that is actually part of CLIM. + +;;; *** A temporary workaround, easier than fixing all references to +;;; *** LISP:<foo>. --RWK 20.Nov.90 +;;; Copied here from defsystem.lisp by York, 5 June 91. +;;; The point of this is to add all the common old aliases for +;;; the ANSI-named COMMON-LISP and COMMON-LISP-USER packages. +;;; I left a copy of this form in defsystem.lisp so that defsystem +;;; can be compiled (it has lots of references to LISP: symbols). +#+ANSI-90 +(eval-when (eval compile load) + (flet ((fix-package (pack-name add-name) + (setq add-name (string add-name)) + (let ((pack (find-package pack-name))) + (assert (not (null pack)) () + "Attempting to add the name ~S to package ~S, which doesn't exist") + (when (null (find-package add-name)) + (let (#+excl(excl::*enable-package-locked-errors* nil)) + (rename-package pack (package-name pack) + (list* add-name (package-nicknames pack)))))))) + (fix-package "COMMON-LISP" "LISP") + (fix-package "COMMON-LISP" "CL") ;; ?? + (fix-package "COMMON-LISP-USER" "USER") + (fix-package "COMMON-LISP-USER" "CL-USER")) ;; ?? + (when (null (find-package "SYSTEM")) + (defpackage system)) +) ;eval-when + +;;; Moved here from sysdcl.lisp, York, 5 June 91 The point of this one +;;; is really to add the ANSI names COMMON-LISP and COMMON-LISP-USER +;;; to the LISP and USER packages found in non-ANSI Lisps. +(eval-when (compile load eval) + (flet ((clean-up-package (old-package-name primary-name required-nicknames) + (let* ((package (or (find-package old-package-name) + (find-package primary-name))) + (old-name (package-name package)) + (old-nicknames (package-nicknames package))) + (let (#+excl(excl::*enable-package-locked-errors* nil)) + (rename-package package primary-name + (remove primary-name (union (cons old-name old-nicknames) + required-nicknames + :test #'string-equal) + :test #'string-equal)))))) + (clean-up-package "LISP" "COMMON-LISP" '("CL")) + (clean-up-package "USER" "COMMON-LISP-USER" '("CL-USER"))) + ) ;eval-when diff --git a/utils/minima-stream-classes.lisp b/utils/minima-stream-classes.lisp new file mode 100644 index 00000000..7c31b266 --- /dev/null +++ b/utils/minima-stream-classes.lisp @@ -0,0 +1,39 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1991, 1992 Symbolics, Inc. All rights reserved." + +;;; Disgusting but apparently effective... +(setf (find-class 'fundamental-stream) + (find-class 'minima-internals::stream)) +(setf (find-class 'fundamental-input-stream) + (find-class 'minima-internals::input-stream)) +(setf (find-class 'fundamental-output-stream) + (find-class 'minima-internals::output-stream)) +(setf (find-class 'fundamental-character-stream) + (find-class 'minima-internals::character-stream)) +(setf (find-class 'fundamental-binary-stream) + (find-class 'minima-internals::binary-stream)) +(setf (find-class 'fundamental-character-input-stream) + (find-class 'minima-internals::character-input-stream)) +(setf (find-class 'fundamental-character-output-stream) + (find-class 'minima-internals::character-output-stream)) +(setf (find-class 'fundamental-binary-input-stream) + (find-class 'minima-internals::binary-input-stream)) +(setf (find-class 'fundamental-binary-output-stream) + (find-class 'minima-internals::binary-output-stream)) + +#+Minima-Runtime +(defun sqrt (x) + (etypecase x + (rational + (let* ((num (numerator x)) + (den (denominator x)) + (shift (- 10 (min (integer-length num) (integer-length den) 10)))) + (/ (isqrt (ash num shift)) (isqrt (ash den shift))))) + )) + +(defun char-bits (char) + (declare (ignore char)) + 0) diff --git a/utils/processes.lisp b/utils/processes.lisp new file mode 100644 index 00000000..5751f565 --- /dev/null +++ b/utils/processes.lisp @@ -0,0 +1,259 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-utils) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. + Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." + +;;; Processes and locks + +(defvar *multiprocessing-p* + #{ + (or Allegro Genera Lucid Lispworks Minima) T + otherwise nil + } + ) + +#+Allegro +(unless (excl::scheduler-running-p) + (mp:start-scheduler)) + +(defmacro with-lock-held ((place &optional state) &body forms) + #+(or Allegro Xerox Genera ccl Minima) + (declare (ignore state #+ccl place)) + #{ + Allegro `(mp:with-process-lock (,place) ,@forms) + Lucid `(lcl:with-process-lock (,place ,@(if state (cons state nil))) + ,@forms) + lispworks `(mp::with-lock (,place) ,@forms) + Xerox `(il:with.monitor ,place ,@forms) + Cloe-Runtime `(progn ,@forms) + Genera `(process:with-lock (,place) ,@forms) + Minima `(minima:with-lock (,place) ,@forms) + CCL-2 `(progn ,@forms) + } + ) + +(defun make-lock (&optional (lock-name "a CLIM lock")) + #-(or Genera Minima) (declare (ignore lock-name)) + #{ + Allegro (mp::make-process-lock) + lispworks (mp::make-lock) + Lucid nil + CCL-2 nil + Xerox (il:create.monitorlock) + Cloe-Runtime nil + Genera (process:make-lock lock-name) + Minima (minima:make-lock lock-name) + } + ) + +;;; A lock that CAN be relocked by the same process. +#-(or Genera Minima) +(defmacro with-simple-recursive-lock ((lock &optional (state "Unlock")) &body forms) + `(flet ((foo () ,@forms)) + (declare (dynamic-extent #'foo)) + (invoke-with-simple-recursive-lock ,lock ,state #'foo))) + +#-(or Genera Minima) +(defun invoke-with-simple-recursive-lock (place state continuation) + (let ((store-value (current-process)) + (place-value (first place))) + (if (and place-value (eql place-value store-value)) + (funcall continuation) + (progn + (unless (null place-value) + (flet ((waiter () + (null (first place)))) + (declare (dynamic-extent #'waiter)) + (process-wait state #'waiter))) + (unwind-protect + (progn (rplaca place store-value) + (funcall continuation)) + (rplaca place nil)))))) + +(defmacro with-recursive-lock-held ((place &optional state) &body forms) + #+(or Allegro Xerox Genera ccl Minima) + (declare (ignore state #+ccl place)) + #{Genera `(process:with-lock (,place) ,@forms) + Minima `(minima:with-lock (,place) ,@forms) + CCL-2 `(progn ,@forms) + otherwise `(with-simple-recursive-lock (,place ,state) ,@forms) + } + ) + +(defun make-recursive-lock (&optional (lock-name "a recursive CLIM lock")) + #-(or Genera Minima) (declare (ignore lock-name)) + #{CCL-2 nil + Genera (process:make-lock lock-name :recursive T) + Minima (minima:make-lock lock-name :recursive T) + otherwise (cons nil nil) + } + ) + +(defmacro without-scheduling (&body forms) + "Evaluate the forms w/o letting any other process run." + #{ + Allegro `(mp:without-scheduling ,@forms) + lispworks `(sys::without-scheduling ,@forms) + Lucid `(lcl:with-scheduling-inhibited ,@forms) + Xerox `(progn ,@forms) + Cloe-Runtime `(progn ,@forms) + ;; should be process:with-no-other-processes if this is used as + ;; a global locking mechanism + Genera `(scl:without-interrupts ,@forms) + Minima `(minima:with-no-other-processes ,@forms) + CCL-2 `(ccl:without-interrupts ,@forms) ; slh + } + ) + +(defun make-process (function &key name) + #+(or ccl) (declare (ignore function name)) + (when *multiprocessing-p* + #{ + lispworks (mp:process-run-function name nil function) + Lucid (lcl:make-process :function function :name name) + Allegro (mp:process-run-function name function) + Xerox (il:add.process (funcall function) 'il:name name) + Genera (scl:process-run-function name function) + Minima (minima:make-process name :initial-function function) + otherwise (warn "No implementation of MAKE-PROCESS for this system.") + })) + +(eval-when (compile load eval) (proclaim '(inline processp))) +(defun processp (object) + #{ + ccl (member object '(:user :event :interrupt)) + Lucid (lcl:processp object) + Allegro (mp::process-p object) + lispworks (mp::process-p object) + ;; In 7.3 and after it is `(process:process-p ,object) + Genera (process:process-p object) + Minima (typep object 'minima-internals::basic-process) + otherwise (progn (warn "No implementation of PROCESSP for this system.") + nil) + } + ) + +(defun destroy-process (p) + #+(or ccl) (declare (ignore p)) + #{ + Lucid (lcl:kill-process p) + Allegro (mp:process-kill p) + lispworks (mp:process-kill p) + Xerox (il:del.process p) + Genera (scl:process-kill p) + Minima (minima:process-kill p) + CCL-2 nil + otherwise (warn "No implementation of DESTROY-PROCESS for this system.") + } + ) + +#+CCL-2 +(defvar *current-process* :user) + +(eval-when (compile load eval) (proclaim '(inline current-process))) +(defun current-process () + #{ + Lucid lcl:*current-process* + Allegro mp:*current-process* + lispworks mp:*current-process* + Xerox (il:this.process) + Genera scl:*current-process* + Minima (minima:current-process) + CCL-2 *current-process* + Cloe-Runtime nil + } + ) + +(eval-when (compile load eval) (proclaim '(inline all-processes))) +(defun all-processes () + #{ + Lucid lcl:*all-processes* + Allegro mp:*all-processes* + lispworks (mp::list-all-processes) + Genera sys:all-processes + CCL-2 (adjoin *current-process* '(:user)) + Cloe-Runtime nil + } + ) + +(defun show-processes () + #{ + Lucid (lcl::show-processes) + Genera (si:com-show-processes) + otherwise (all-processes) + } + ) + +(eval-when (compile load eval) (proclaim '(inline process-yield))) +(defun process-yield () + #{ + Lucid (lcl:process-allow-schedule) + Allegro (mp:process-allow-schedule) + lispworks (mp::process-allow-scheduling) + Xerox (il:block) + Genera (scl:process-allow-schedule) + Minima (sleep 1/10) + CCL-2 (ccl:event-dispatch) + Cloe-Runtime nil + } + ) + +(defun process-wait (wait-reason predicate) + "Cause the current process to go to sleep until the predicate returns TRUE." + #{ + Lucid (lcl:process-wait wait-reason predicate) + Allegro (mp:process-wait wait-reason predicate) + lispworks (mp:process-wait wait-reason predicate) + Xerox (let ((il:*who-line-state* wait-reason)) + (loop + (il:block) + (when (and (funcall predicate)) + (return)))) + CCL-2 (ccl::process-wait wait-reason predicate) + Cloe-Runtime nil + Genera (scl:process-wait wait-reason predicate) + Minima (minima:process-wait wait-reason predicate) + otherwise (progn (compile-time-warn "Need an implementation for PROCESS-WAIT") + (error "~S doesn't have a definition. Args are ~S ~S" + 'process-wait wait-reason predicate)) + } + ) + +(defun process-wait-with-timeout (wait-reason timeout predicate) + "Cause the current process to go to sleep until the predicate returns TRUE or + timeout seconds have gone by." + (when (null timeout) + ;; ensure genera semantics, timeout = NIL means indefinite timeout + (return-from process-wait-with-timeout + (process-wait wait-reason predicate))) + #{ + Allegro (mp:process-wait-with-timeout wait-reason timeout predicate) + lispworks (mp:process-wait-with-timeout wait-reason timeout predicate) + Lucid (lcl:process-wait-with-timeout wait-reason timeout predicate) + Genera (sys:process-wait-with-timeout wait-reason (* timeout 60.) predicate) + CCL-2 (ccl::process-wait-with-timeout wait-reason timeout predicate) + otherwise (progn (compile-time-warn "Need an implementation for process-wait-with-timeout") + (error "~S doesn't have a definition. Args are ~S ~S ~S" + 'process-wait-with-timeout timeout wait-reason predicate)) + } + ) + +(defun process-interrupt (process closure) + (declare #+CCL-2 (ignore process)) + #{ + Lucid (lcl:interrupt-process process closure) + Allegro (mp:process-interrupt process closure) + ;; --- Is Lispworks' the same as Allegro? + ;; --- It is for everything else except ALL-PROCESSES. + Genera (scl:process-interrupt process closure) + CCL-2 (let ((*current-process* :interrupt)) + (funcall closure)) + Minima (minima:process-interrupt process closure) + otherwise (progn + (compile-time-warn "Need an implementation for process-interrupt") + (error "~S doesn't have a definition. Args are ~S ~S" + 'process-interrupt process closure)) + } + ) -- GitLab